diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -12,7 +12,7 @@ import Distribution.Simple.LocalBuildInfo (absoluteInstallDirs, InstallDirs(..)) lhclibdir = "lib" -libsToBuild = map (lhclibdir ) [ "ghc-prim", "integer-native", "base" ] +libsToBuild = map (lhclibdir ) [ "ghc-prim", "integer-ltm", "base" ] main = defaultMainWithHooks simpleUserHooks { postInst = myPostInst } where myPostInst _ _ pkgdesc buildinfo = do @@ -29,15 +29,16 @@ customF = customFieldsBI binfo -- initial setup udir' <- getAppUserDataDirectory "lhc" + createDirectoryIfMissing True (udir' "packages") -- NOTE - THIS MUST BE KEPT IN SYNC WITH -- lhc-pkg in lhc-pkg/Main.hs!!! let udir = udir' (SysVer.arch ++ "-" ++ SysVer.os ++ "-" ++ (showVersion pkgVer)) - pkgconf = udir "package" <.> "conf" - b <- doesFileExist pkgconf + pkgconf = udir "package" <.> "conf.d" + createDirectoryIfMissing True udir + b <- doesDirectoryExist pkgconf unless b $ do - putStr "Creating initial package.conf file..." - createDirectoryIfMissing True udir - writeFile (udir "package.conf") "[]\n" + putStr "Creating initial package.conf.d database..." + system $ "lhc-pkg init " ++ pkgconf putStrLn "Done" -- copy over extra-gcc-opts and unlit from @@ -56,7 +57,7 @@ when (withLibs customF) $ do let confargs = unwords [ "--lhc", "--with-lhc="++lhc, "--with-lhc-pkg="++lhcpkg , "--prefix="++show (prefix (installDirTemplates buildinfo)) - , "--extra-include-dirs="++(ghcLibdir"include") ] + ] putStrLn "building libraries..." installLhcPkgs confargs libsToBuild @@ -66,7 +67,7 @@ putStrLn $ "\n[installing "++n++" package for lhc]\n" let x = unwords ["cd",n ,"&&","runghc Setup configure",cf - ,"&&","runghc Setup build" + ,"&&","(runghc Setup build || runghc Setup build)" ,"&&","runghc Setup copy" ,"&&","runghc Setup register"] putStrLn $ x diff --git a/lhc-pkg/Main.hs b/lhc-pkg/Main.hs --- a/lhc-pkg/Main.hs +++ b/lhc-pkg/Main.hs @@ -1,1357 +1,27 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2004. --- --- Package management tool --- ------------------------------------------------------------------------------ - --- TODO: --- * validate modules --- * expanding of variables in new-style package conf --- * version manipulation (checking whether old version exists, --- hiding old version?) - -module Main (main) where - -import Paths_lhc -import System.Info -import Data.Version -import Distribution.ModuleName hiding (main) -import Distribution.InstalledPackageInfo hiding (depends) -import Distribution.Compat.ReadP -import Distribution.ParseUtils -import Distribution.Package -import Distribution.Text -import Distribution.Version -import System.FilePath -import System.Cmd ( rawSystem ) -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) - -import Prelude - -import System.Console.GetOpt -import Text.PrettyPrint -#if __GLASGOW_HASKELL__ >= 609 -import qualified Control.Exception as Exception -#else -import qualified Control.Exception.Extensible as Exception -#endif -import Data.Maybe - -import Data.Char ( isSpace, toLower ) -import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, renameFile, removeFile ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.Environment ( getArgs, getProgName, getEnv ) -import System.IO -import System.IO.Error (try) -import Data.List -import Control.Concurrent - -import Foreign -import Foreign.C -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler -#else -import System.Posix hiding (fdToHandle,version) -#endif - -import IO ( isPermissionError ) -import System.Posix.Internals -import GHC.Handle (fdToHandle) - -#if defined(GLOB) -import System.Process(runInteractiveCommand) -import qualified System.Info(os) -#endif - --- ----------------------------------------------------------------------------- --- Entry point - -main :: IO () -main = do - args <- getArgs - - case getOpt Permute (flags ++ deprecFlags) args of - (cli,_,[]) | FlagHelp `elem` cli -> do - prog <- getProgramName - bye (usageInfo (usageHeader prog) flags) - (cli,_,[]) | FlagVersion `elem` cli -> - bye ourCopyright - (cli,nonopts,[]) -> - runit cli nonopts - (_,_,errors) -> do - prog <- getProgramName - die (concat errors ++ usageInfo (usageHeader prog) flags) - --- ----------------------------------------------------------------------------- --- Command-line syntax - -data Flag - = FlagUser - | FlagGlobal - | FlagHelp - | FlagVersion - | FlagConfig FilePath - | FlagGlobalConfig FilePath - | FlagForce - | FlagForceFiles - | FlagAutoGHCiLibs - | FlagSimpleOutput - | FlagNamesOnly - | FlagIgnoreCase - | FlagNoUserDb - deriving Eq - -flags :: [OptDescr Flag] -flags = [ - Option [] ["user"] (NoArg FlagUser) - "use the current user's package database", - Option [] ["global"] (NoArg FlagGlobal) - "use the global package database", - Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE") - "use the specified package config file", - Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") - "location of the global package config", - Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) - "never read the user package database", - Option [] ["force"] (NoArg FlagForce) - "ignore missing dependencies, directories, and libraries", - Option [] ["force-files"] (NoArg FlagForceFiles) - "ignore missing directories and libraries only", - Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) - "automatically build libs for GHCi (with register)", - Option ['?'] ["help"] (NoArg FlagHelp) - "display this help and exit", - Option ['V'] ["version"] (NoArg FlagVersion) - "output version information and exit", - Option [] ["simple-output"] (NoArg FlagSimpleOutput) - "print output in easy-to-parse format for some commands", - Option [] ["names-only"] (NoArg FlagNamesOnly) - "only print package names, not versions; can only be used with list --simple-output", - Option [] ["ignore-case"] (NoArg FlagIgnoreCase) - "ignore case for substring matching" - ] - -deprecFlags :: [OptDescr Flag] -deprecFlags = [ - -- put deprecated flags here - ] - -ourCopyright :: String -ourCopyright = "LHC package manager version " ++ showVersion version ++ "\n" - -usageHeader :: String -> String -usageHeader prog = substProg prog $ - "Usage:\n" ++ - " $p register {filename | -}\n" ++ - " Register the package using the specified installed package\n" ++ - " description. The syntax for the latter is given in the $p\n" ++ - " documentation.\n" ++ - "\n" ++ - " $p update {filename | -}\n" ++ - " Register the package, overwriting any other package with the\n" ++ - " same name.\n" ++ - "\n" ++ - " $p unregister {pkg-id}\n" ++ - " Unregister the specified package.\n" ++ - "\n" ++ - " $p expose {pkg-id}\n" ++ - " Expose the specified package.\n" ++ - "\n" ++ - " $p hide {pkg-id}\n" ++ - " Hide the specified package.\n" ++ - "\n" ++ - " $p list [pkg]\n" ++ - " List registered packages in the global database, and also the\n" ++ - " user database if --user is given. If a package name is given\n" ++ - " all the registered versions will be listed in ascending order.\n" ++ - " Accepts the --simple-output flag.\n" ++ - "\n" ++ - " $p find-module {module}\n" ++ - " List registered packages exposing module {module} in the global\n" ++ - " database, and also the user database if --user is given.\n" ++ - " All the registered versions will be listed in ascending order.\n" ++ - " Accepts the --simple-output flag.\n" ++ - "\n" ++ - " $p latest {pkg-id}\n" ++ - " Prints the highest registered version of a package.\n" ++ - "\n" ++ - " $p check\n" ++ - " Check the consistency of package depenencies and list broken packages.\n" ++ - " Accepts the --simple-output flag.\n" ++ - "\n" ++ - " $p describe {pkg}\n" ++ - " Give the registered description for the specified package. The\n" ++ - " description is returned in precisely the syntax required by $p\n" ++ - " register.\n" ++ - "\n" ++ - " $p field {pkg} {field}\n" ++ - " Extract the specified field of the package description for the\n" ++ - " specified package. Accepts comma-separated multiple fields.\n" ++ - "\n" ++ - " $p dump\n" ++ - " Dump the registered description for every package. This is like\n" ++ - " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ - " by tools that parse the results, rather than humans.\n" ++ - "\n" ++ - " Substring matching is supported for {module} in find-module and\n" ++ - " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ - " open substring ends (prefix*, *suffix, *infix*).\n" ++ - "\n" ++ - " When asked to modify a database (register, unregister, update,\n"++ - " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ - " default. Specifying --user causes it to act on the user database,\n"++ - " or --package-conf can be used to act on another database\n"++ - " entirely. When multiple of these options are given, the rightmost\n"++ - " one is used as the database to act upon.\n"++ - "\n"++ - " Commands that query the package database (list, latest, describe,\n"++ - " field) operate on the list of databases specified by the flags\n"++ - " --user, --global, and --package-conf. If none of these flags are\n"++ - " given, the default is --global --user.\n"++ - "\n" ++ - " The following optional flags are also accepted:\n" - -substProg :: String -> String -> String -substProg _ [] = [] -substProg prog ('$':'p':xs) = prog ++ substProg prog xs -substProg prog (c:xs) = c : substProg prog xs - --- ----------------------------------------------------------------------------- --- Do the business - -data Force = NoForce | ForceFiles | ForceAll | CannotForce - deriving (Eq,Ord) - -data PackageArg = Id PackageIdentifier | Substring String (String->Bool) - -runit :: [Flag] -> [String] -> IO () -runit cli nonopts = do - installSignalHandlers -- catch ^C and clean up - prog <- getProgramName - let - force - | FlagForce `elem` cli = ForceAll - | FlagForceFiles `elem` cli = ForceFiles - | otherwise = NoForce - auto_ghci_libs = FlagAutoGHCiLibs `elem` cli - splitFields fields = unfoldr splitComma (',':fields) - where splitComma "" = Nothing - splitComma fs = Just $ break (==',') (tail fs) - - substringCheck :: String -> Maybe (String -> Bool) - substringCheck "" = Nothing - substringCheck "*" = Just (const True) - substringCheck [_] = Nothing - substringCheck (h:t) = - case (h, init t, last t) of - ('*',s,'*') -> Just (isInfixOf (f s) . f) - ('*',_, _ ) -> Just (isSuffixOf (f t) . f) - ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f) - _ -> Nothing - where f | FlagIgnoreCase `elem` cli = map toLower - | otherwise = id -#if defined(GLOB) - glob x | System.Info.os=="mingw32" = do - -- glob echoes its argument, after win32 filename globbing - (_,o,_,_) <- runInteractiveCommand ("glob "++x) - txt <- hGetContents o - return (read txt) - glob x | otherwise = return [x] -#endif - -- - -- first, parse the command - case nonopts of -#if defined(GLOB) - -- dummy command to demonstrate usage and permit testing - -- without messing things up; use glob to selectively enable - -- windows filename globbing for file parameters - -- register, update, FlagGlobalConfig, FlagConfig; others? - ["glob", filename] -> do - print filename - glob filename >>= print -#endif - ["register", filename] -> - registerPackage filename cli auto_ghci_libs False force - ["update", filename] -> - registerPackage filename cli auto_ghci_libs True force - ["unregister", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid cli force - ["expose", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli force - ["hide", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli force - ["list"] -> do - listPackages cli Nothing Nothing - ["list", pkgid_str] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just (Id pkgid)) Nothing - Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing - ["find-module", moduleName] -> do - let match = maybe (==moduleName) id (substringCheck moduleName) - listPackages cli Nothing (Just match) - ["latest", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - latestPackage cli pkgid - ["describe", pkgid_str] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - describePackage cli (Id pkgid) - Just m -> describePackage cli (Substring pkgid_str m) - ["field", pkgid_str, fields] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - describeField cli (Id pkgid) (splitFields fields) - Just m -> describeField cli (Substring pkgid_str m) - (splitFields fields) - ["check"] -> do - checkConsistency cli - - ["dump"] -> do - dumpPackages cli - - [] -> do - die ("missing command\n" ++ - usageInfo (usageHeader prog) flags) - (_cmd:_) -> do - die ("command-line syntax error\n" ++ - usageInfo (usageHeader prog) flags) - -parseCheck :: ReadP a a -> String -> String -> IO a -parseCheck parser str what = - case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of - [x] -> return x - _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) - -readGlobPkgId :: String -> IO PackageIdentifier -readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" - -parseGlobPackageId :: ReadP r PackageIdentifier -parseGlobPackageId = - parse - +++ - (do n <- parse - string "-*" - return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) - --- globVersion means "all versions" -globVersion :: Version -globVersion = Version{ versionBranch=[], versionTags=["*"] } - --- ----------------------------------------------------------------------------- --- Package databases - --- Some commands operate on a single database: --- register, unregister, expose, hide --- however these commands also check the union of the available databases --- in order to check consistency. For example, register will check that --- dependencies exist before registering a package. --- --- Some commands operate on multiple databases, with overlapping semantics: --- list, describe, field - -type PackageDBName = FilePath -type PackageDB = [InstalledPackageInfo] - -type NamedPackageDB = (PackageDBName, PackageDB) -type PackageDBStack = [NamedPackageDB] - -- A stack of package databases. Convention: head is the topmost - -- in the stack. Earlier entries override later one. - -allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] -allPackagesInStack = concatMap snd - -getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName) -getPkgDatabases modify my_flags = do - -- first we determine the location of the global package config. On Windows, - -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the - -- location is passed to the binary using the --global-config flag by the - -- wrapper script. - let err_msg = "missing --global-conf option, location of global package.conf unknown\n" - global_conf <- - case [ f | FlagGlobalConfig f <- my_flags ] of - [] -> return Nothing{-do let globalConfPath = "/usr/local/lib/lhc/package.conf" - exist <- doesFileExist globalConfPath - if exist then return $ Just globalConfPath - else return $ Nothing-} - fs -> return $ Just (last fs) - - let global_conf_dir = fromMaybe "" global_conf ++ ".d" - global_conf_dir_exists <- doesDirectoryExist global_conf_dir - global_confs <- - if global_conf_dir_exists - then do files <- getDirectoryContents global_conf_dir - return [ global_conf_dir ++ '/' : file - | file <- files - , isSuffixOf ".conf" file] - else return [] - - let no_user_db = FlagNoUserDb `elem` my_flags - - -- get the location of the user package database, and create it if necessary - -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) - appdir <- try $ getAppUserDataDirectory "lhc" - - let targetARCH = arch - targetOS = os - mb_user_conf <- - if no_user_db then return Nothing else - case appdir of - Right dir -> do - let subdir = targetARCH ++ '-':targetOS ++ '-':showVersion version - user_conf = dir subdir "package.conf" - user_exists <- doesFileExist user_conf - return (Just (user_conf,user_exists)) - Left _ -> - return Nothing - - -- If the user database doesn't exist, and this command isn't a - -- "modify" command, then we won't attempt to create or use it. - let sys_databases - | Just (user_conf,user_exists) <- mb_user_conf, - modify || user_exists = user_conf : global_confs ++ catMaybes [global_conf] - | otherwise = global_confs ++ catMaybes [global_conf] - - e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") - let env_stack = - case e_pkg_path of - Left _ -> sys_databases - Right path - | last cs == "" -> init cs ++ sys_databases - | otherwise -> cs - where cs = parseSearchPath path - - -- The "global" database is always the one at the bottom of the stack. - -- This is the database we modify by default. - virt_global_conf = last env_stack - - let db_flags = [ f | Just f <- map is_db_flag my_flags ] - where is_db_flag FlagUser - | Just (user_conf, _user_exists) <- mb_user_conf - = Just user_conf - is_db_flag FlagGlobal = Just virt_global_conf - is_db_flag (FlagConfig f) = Just f - is_db_flag _ = Nothing - - (final_stack, to_modify) <- - if not modify - then -- For a "read" command, we use all the databases - -- specified on the command line. If there are no - -- command-line flags specifying databases, the default - -- is to use all the ones we know about. - if null db_flags then return (env_stack, Nothing) - else return (reverse (nub db_flags), Nothing) - else let - -- For a "modify" command, treat all the databases as - -- a stack, where we are modifying the top one, but it - -- can refer to packages in databases further down the - -- stack. - - -- -f flags on the command line add to the database - -- stack, unless any of them are present in the stack - -- already. - flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse my_flags ] - ++ env_stack - - -- the database we actually modify is the one mentioned - -- rightmost on the command-line. - to_modify = if null db_flags - then Just virt_global_conf - else Just (last db_flags) - in - return (flag_stack, to_modify) - - db_stack <- mapM (readParseDatabase mb_user_conf) final_stack - return (db_stack, to_modify) - -readParseDatabase :: Maybe (PackageDBName,Bool) - -> PackageDBName - -> IO (PackageDBName,PackageDB) -readParseDatabase mb_user_conf filename - -- the user database (only) is allowed to be non-existent - | Just (user_conf,False) <- mb_user_conf, filename == user_conf - = return (filename, []) - | otherwise - = do str <- readFile filename - let packages = map convertPackageInfoIn $ read str - Exception.evaluate packages - `catchError` \e-> - die ("error while parsing " ++ filename ++ ": " ++ show e) - return (filename,packages) - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage :: FilePath - -> [Flag] - -> Bool -- auto_ghci_libs - -> Bool -- update - -> Force - -> IO () -registerPackage input my_flags auto_ghci_libs update force = do - (db_stack, Just to_modify) <- getPkgDatabases True my_flags - let - db_to_operate_on = my_head "register" $ - filter ((== to_modify).fst) db_stack - -- - s <- - case input of - "-" -> do - putStr "Reading package info from stdin ... " - getContents - f -> do - putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f - - expanded <- expandEnvVars s force - - pkg <- parsePackageInfo expanded - putStrLn "done." - - let unversioned_deps = filter (not . realVersion) (depends pkg) - unless (null unversioned_deps) $ - die ("Unversioned dependencies found: " ++ - unwords (map display unversioned_deps)) - - let truncated_stack = dropWhile ((/= to_modify).fst) db_stack - -- truncate the stack for validation, because we don't allow - -- packages lower in the stack to refer to those higher up. - validatePackageConfig pkg truncated_stack auto_ghci_libs update force - let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] - not_this p = package p /= package pkg - writeNewConfig to_modify new_details - -parsePackageInfo - :: String - -> IO InstalledPackageInfo -parsePackageInfo str = - case parseInstalledPackageInfo str of - ParseOk _warns ok -> return ok - ParseFailed err -> case locatedErrorMsg err of - (Nothing, s) -> die s - (Just l, s) -> die (show l ++ ": " ++ s) - --- ----------------------------------------------------------------------------- --- Exposing, Hiding, Unregistering are all similar - -exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO () -exposePackage = modifyPackage (\p -> [p{exposed=True}]) - -hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO () -hidePackage = modifyPackage (\p -> [p{exposed=False}]) - -unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO () -unregisterPackage = modifyPackage (\_ -> []) - -modifyPackage - :: (InstalledPackageInfo -> [InstalledPackageInfo]) - -> PackageIdentifier - -> [Flag] - -> Force - -> IO () -modifyPackage fn pkgid my_flags force = do - (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags - ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) --- let ((db_name, pkgs) : rest_of_stack) = db_stack --- ps <- findPackages [(db_name,pkgs)] (Id pkgid) - let - pids = map package ps - modify pkg - | package pkg `elem` pids = fn pkg - | otherwise = [pkg] - new_config = concat (map modify pkgs) - - let - old_broken = brokenPackages (allPackagesInStack db_stack) - rest_of_stack = [ (nm, mypkgs) - | (nm, mypkgs) <- db_stack, nm /= db_name ] - new_stack = (db_name,new_config) : rest_of_stack - new_broken = map package (brokenPackages (allPackagesInStack new_stack)) - newly_broken = filter (`notElem` map package old_broken) new_broken - -- - when (not (null newly_broken)) $ - dieOrForceAll force ("unregistering " ++ display pkgid ++ - " would break the following packages: " - ++ unwords (map display newly_broken)) - - writeNewConfig db_name new_config - --- ----------------------------------------------------------------------------- --- Listing packages - -listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () -listPackages my_flags mPackageName mModuleName = do - let simple_output = FlagSimpleOutput `elem` my_flags - (db_stack, _) <- getPkgDatabases False my_flags - let db_stack_filtered -- if a package is given, filter out all other packages - | Just this <- mPackageName = - map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) - db_stack - | Just match <- mModuleName = -- packages which expose mModuleName - map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs)) - db_stack - | otherwise = db_stack - - db_stack_sorted - = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ] - where sort_pkgs = sortBy cmpPkgIds - cmpPkgIds pkg1 pkg2 = - case pkgName p1 `compare` pkgName p2 of - LT -> LT - GT -> GT - EQ -> pkgVersion p1 `compare` pkgVersion p2 - where (p1,p2) = (package pkg1, package pkg2) - - match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) - - pkg_map = allPackagesInStack db_stack - show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) - - show_func (reverse db_stack_sorted) - - where show_normal pkg_map (db_name,pkg_confs) = - hPutStrLn stdout (render $ - text db_name <> colon $$ nest 4 packages - ) - where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - broken = map package (brokenPackages pkg_map) - pp_pkg p - | package p `elem` broken = braces doc - | exposed p = doc - | otherwise = parens doc - where doc = text (display (package p)) - - show_simple = simplePackageList my_flags . allPackagesInStack - -simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () -simplePackageList my_flags pkgs = do - let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName - else display - strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs - when (not (null pkgs)) $ - hPutStrLn stdout $ concat $ intersperse " " strs - --- ----------------------------------------------------------------------------- --- Prints the highest (hidden or exposed) version of a package - -latestPackage :: [Flag] -> PackageIdentifier -> IO () -latestPackage my_flags pkgid = do - (db_stack, _) <- getPkgDatabases False my_flags - ps <- findPackages db_stack (Id pkgid) - show_pkg (sortBy compPkgIdVer (map package ps)) - where - show_pkg [] = die "no matches" - show_pkg pids = hPutStrLn stdout (display (last pids)) - --- ----------------------------------------------------------------------------- --- Describe - -describePackage :: [Flag] -> PackageArg -> IO () -describePackage my_flags pkgarg = do - (db_stack, _) <- getPkgDatabases False my_flags - ps <- findPackages db_stack pkgarg - doDump ps - -dumpPackages :: [Flag] -> IO () -dumpPackages my_flags = do - (db_stack, _) <- getPkgDatabases False my_flags - doDump (allPackagesInStack db_stack) - -doDump :: [InstalledPackageInfo] -> IO () -doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo - --- PackageId is can have globVersion for the version -findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] -findPackages db_stack pkgarg - = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg - -findPackagesByDB :: PackageDBStack -> PackageArg - -> IO [(NamedPackageDB, [InstalledPackageInfo])] -findPackagesByDB db_stack pkgarg - = case [ (db, matched) - | db@(_, pkgs) <- db_stack, - let matched = filter (pkgarg `matchesPkg`) pkgs, - not (null matched) ] of - [] -> die ("cannot find package " ++ pkg_msg pkgarg) - ps -> return ps - where - pkg_msg (Id pkgid) = display pkgid - pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat - -matches :: PackageIdentifier -> PackageIdentifier -> Bool -pid `matches` pid' - = (pkgName pid == pkgName pid') - && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) - -matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool -(Id pid) `matchesPkg` pkg = pid `matches` package pkg -(Substring _ m) `matchesPkg` pkg = m (display (package pkg)) - -compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering -compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 - --- ----------------------------------------------------------------------------- --- Field - -describeField :: [Flag] -> PackageArg -> [String] -> IO () -describeField my_flags pkgarg fields = do - (db_stack, _) <- getPkgDatabases False my_flags - fns <- toFields fields - ps <- findPackages db_stack pkgarg - let top_dir = takeDirectory (fst (last db_stack)) - mapM_ (selectFields fns) (mungePackagePaths top_dir ps) - where toFields [] = return [] - toFields (f:fs) = case toField f of - Nothing -> die ("unknown field: " ++ f) - Just fn -> do fns <- toFields fs - return (fn:fns) - selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns - -mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] --- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path --- with the current topdir (obtained from the -B option). -mungePackagePaths top_dir ps = map munge_pkg ps - where - munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p), - haddockInterfaces = munge_paths (haddockInterfaces p), - haddockHTMLs = munge_paths (haddockHTMLs p) - } - - munge_paths = map munge_path - - munge_path p - | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' - | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' - | otherwise = p - - toHttpPath p = "file:///" ++ p - -maybePrefixMatch :: String -> String -> Maybe String -maybePrefixMatch [] rest = Just rest -maybePrefixMatch (_:_) [] = Nothing -maybePrefixMatch (p:pat) (r:rest) - | p == r = maybePrefixMatch pat rest - | otherwise = Nothing - -toField :: String -> Maybe (InstalledPackageInfo -> String) --- backwards compatibility: -toField "import_dirs" = Just $ strList . importDirs -toField "source_dirs" = Just $ strList . importDirs -toField "library_dirs" = Just $ strList . libraryDirs -toField "hs_libraries" = Just $ strList . hsLibraries -toField "extra_libraries" = Just $ strList . extraLibraries -toField "include_dirs" = Just $ strList . includeDirs -toField "c_includes" = Just $ strList . includes -toField "package_deps" = Just $ strList . map display. depends -toField "extra_cc_opts" = Just $ strList . ccOptions -toField "extra_ld_opts" = Just $ strList . ldOptions -toField "framework_dirs" = Just $ strList . frameworkDirs -toField "extra_frameworks"= Just $ strList . frameworks -toField s = showInstalledPackageInfoField s - -strList :: [String] -> String -strList = show - - --- ----------------------------------------------------------------------------- --- Check: Check consistency of installed packages - -checkConsistency :: [Flag] -> IO () -checkConsistency my_flags = do - (db_stack, _) <- getPkgDatabases True my_flags - -- check behaves like modify for the purposes of deciding which - -- databases to use, because ordering is important. - - let simple_output = FlagSimpleOutput `elem` my_flags - - let pkgs = allPackagesInStack db_stack - - checkPackage p = do - (_,es) <- runValidate $ checkPackageConfig p db_stack False True - if null es - then return [] - else do - when (not simple_output) $ do - reportError ("There are problems in package " ++ display (package p) ++ ":") - reportValidateErrors es " " Nothing - return () - return [p] - - broken_pkgs <- concat `fmap` mapM checkPackage pkgs - - let filterOut pkgs1 pkgs2 = filter not_in pkgs2 - where not_in p = package p `notElem` all_ps - all_ps = map package pkgs1 - - let not_broken_pkgs = filterOut broken_pkgs pkgs - (_, trans_broken_pkgs) = closure [] not_broken_pkgs - all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs - - when (not (null all_broken_pkgs)) $ do - if simple_output - then simplePackageList my_flags all_broken_pkgs - else do - reportError ("\nThe following packages are broken, either because they have a problem\n"++ - "listed above, or because they depend on a broken package.") - mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs - - when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) - - -closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] - -> ([InstalledPackageInfo], [InstalledPackageInfo]) -closure pkgs db_stack = go pkgs db_stack - where - go avail not_avail = - case partition (depsAvailable avail) not_avail of - ([], not_avail') -> (avail, not_avail') - (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' - - depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo - -> Bool - depsAvailable pkgs_ok pkg = null dangling - where dangling = filter (`notElem` pids) (depends pkg) - pids = map package pkgs_ok - - -- we want mutually recursive groups of package to show up - -- as broken. (#1750) - -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = snd (closure [] pkgs) - --- ----------------------------------------------------------------------------- --- Manipulating package.conf files - -type InstalledPackageInfoString = InstalledPackageInfo_ String - -convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString -convertPackageInfoOut - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = map display e, - hiddenModules = map display h } - -convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo -convertPackageInfoIn - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = map convert e, - hiddenModules = map convert h } - where convert = fromJust . simpleParse - -writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () -writeNewConfig filename packages = do - hPutStr stdout "Writing new package config file... " - createDirectoryIfMissing True $ takeDirectory filename - let shown = concat $ intersperse ",\n " - $ map (show . convertPackageInfoOut) packages - fileContents = "[" ++ shown ++ "\n]" - writeFileAtomic filename fileContents - `catch` \e -> - if isPermissionError e - then die (filename ++ ": you don't have permission to modify this file") - else ioError e - hPutStrLn stdout "done." - ------------------------------------------------------------------------------ --- Sanity-check a new package config, and automatically build GHCi libs --- if requested. - -type ValidateError = (Force,String) - -newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } - -instance Monad Validate where - return a = V $ return (a, []) - m >>= k = V $ do - (a, es) <- runValidate m - (b, es') <- runValidate (k a) - return (b,es++es') - -verror :: Force -> String -> Validate () -verror f s = V (return ((),[(f,s)])) - -liftIO :: IO a -> Validate a -liftIO k = V (k >>= \a -> return (a,[])) - --- returns False if we should die -reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool -reportValidateErrors es prefix mb_force = do - oks <- mapM report es - return (and oks) - where - report (f,s) - | Just force <- mb_force - = if (force >= f) - then do reportError (prefix ++ s ++ " (ignoring)") - return True - else if f < CannotForce - then do reportError (prefix ++ s ++ " (use --force to override)") - return False - else do reportError err - return False - | otherwise = do reportError err - return False - where - err = prefix ++ s - -validatePackageConfig :: InstalledPackageInfo - -> PackageDBStack - -> Bool -- auto-ghc-libs - -> Bool -- update, or check - -> Force - -> IO () -validatePackageConfig pkg db_stack auto_ghci_libs update force = do - (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update - ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force) - when (not ok) $ exitWith (ExitFailure 1) - -checkPackageConfig :: InstalledPackageInfo - -> PackageDBStack - -> Bool -- auto-ghc-libs - -> Bool -- update, or check - -> Validate () -checkPackageConfig pkg db_stack auto_ghci_libs update = do - checkPackageId pkg - checkDuplicates db_stack pkg update - mapM_ (checkDep db_stack) (depends pkg) - checkDuplicateDepends (depends pkg) - mapM_ (checkDir "import-dirs") (importDirs pkg) - mapM_ (checkDir "library-dirs") (libraryDirs pkg) - mapM_ (checkDir "include-dirs") (includeDirs pkg) - checkModules pkg - mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) - -- ToDo: check these somehow? - -- extra_libraries :: [String], - -- c_includes :: [String], - --- When the package name and version are put together, sometimes we can --- end up with a package id that cannot be parsed. This will lead to --- difficulties when the user wants to refer to the package later, so --- we check that the package id can be parsed properly here. -checkPackageId :: InstalledPackageInfo -> Validate () -checkPackageId ipi = - let str = display (package ipi) in - case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of - [_] -> return () - [] -> verror CannotForce ("invalid package identifier: " ++ str) - _ -> verror CannotForce ("ambiguous package identifier: " ++ str) - -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () -checkDuplicates db_stack pkg update = do - let - pkgid = package pkg - (_top_db_name, pkgs) : _ = db_stack - -- - -- Check whether this package id already exists in this DB - -- - when (not update && (pkgid `elem` map package pkgs)) $ - verror CannotForce $ - "package " ++ display pkgid ++ " is already installed" - - let - uncasep = map toLower . display - dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) - - when (not update && not (null dups)) $ verror ForceAll $ - "Package names may be treated case-insensitively in the future.\n"++ - "Package " ++ display pkgid ++ - " overlaps with: " ++ unwords (map display dups) - - -checkDir :: String -> String -> Validate () -checkDir thisfield d - | "$topdir" `isPrefixOf` d = return () - | "$httptopdir" `isPrefixOf` d = return () - -- can't check these, because we don't know what $(http)topdir is - | otherwise = do - there <- liftIO $ doesDirectoryExist d - when (not there) $ - verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") - -checkDep :: PackageDBStack -> PackageIdentifier -> Validate () -checkDep db_stack pkgid - | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = verror ForceAll ("dependency " ++ display pkgid - ++ " doesn't exist") - where - -- for backwards compat, we treat 0.0 as a special version, - -- and don't check that it actually exists. - real_version = realVersion pkgid - - name_exists = any (\p -> pkgName (package p) == name) all_pkgs - name = pkgName pkgid - - all_pkgs = allPackagesInStack db_stack - pkgids = map package all_pkgs - -checkDuplicateDepends :: [PackageIdentifier] -> Validate () -checkDuplicateDepends deps - | null dups = return () - | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ - unwords (map display dups)) - where - dups = [ p | (p:_:_) <- group (sort deps) ] - -realVersion :: PackageIdentifier -> Bool -realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] - -checkHSLib :: [String] -> Bool -> String -> Validate () -checkHSLib dirs auto_ghci_libs lib = do - let batch_lib_file = "lib" ++ lib ++ ".a" - m <- liftIO $ doesFileExistOnPath batch_lib_file dirs - case m of - Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ - " on library path") - Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs - -doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) -doesFileExistOnPath file path = go path - where go [] = return Nothing - go (p:ps) = do b <- doesFileExistIn file p - if b then return (Just p) else go ps - -doesFileExistIn :: String -> String -> IO Bool -doesFileExistIn lib d - | "$topdir" `isPrefixOf` d = return True - | "$httptopdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d lib) - -checkModules :: InstalledPackageInfo -> Validate () -checkModules pkg = do - mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) - where - findModule modl = do - -- there's no .hi file for GHC.Prim - if components modl == ["GHC", "Prim"] then return () else do - let file = toFilePath modl <.> "hi" - m <- liftIO $ doesFileExistOnPath file (importDirs pkg) - when (isNothing m) $ - verror ForceFiles ("file " ++ file ++ " is missing") - -checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () -checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build - | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = do - m <- doesFileExistOnPath ghci_lib_file dirs - when (isNothing m) $ - hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) - where - ghci_lib_file = lib <.> "o" - --- automatically build the GHCi version of a batch lib, --- using ld --whole-archive. - -autoBuildGHCiLib :: String -> String -> String -> IO () -autoBuildGHCiLib dir batch_file ghci_file = do - let ghci_lib_file = dir ++ '/':ghci_file - batch_lib_file = dir ++ '/':batch_file - hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...") -#if defined(darwin_HOST_OS) - r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] -#elif defined(mingw32_HOST_OS) - execDir <- getExecDir "/bin/ghc-pkg.exe" - r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] -#else - r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] -#endif - when (r /= ExitSuccess) $ exitWith r - hPutStrLn stderr (" done.") - --- ----------------------------------------------------------------------------- --- Searching for modules - -#if not_yet - -findModules :: [FilePath] -> IO [String] -findModules paths = - mms <- mapM searchDir paths - return (concat mms) - -searchDir path prefix = do - fs <- getDirectoryEntries path `catch` \_ -> return [] - searchEntries path prefix fs - -searchEntries path prefix [] = return [] -searchEntries path prefix (f:fs) - | looks_like_a_module = do - ms <- searchEntries path prefix fs - return (prefix `joinModule` f : ms) - | looks_like_a_component = do - ms <- searchDir (path f) (prefix `joinModule` f) - ms' <- searchEntries path prefix fs - return (ms ++ ms') - | otherwise - searchEntries path prefix fs - - where - (base,suffix) = splitFileExt f - looks_like_a_module = - suffix `elem` haskell_suffixes && - all okInModuleName base - looks_like_a_component = - null suffix && all okInModuleName base - -okInModuleName c - -#endif - --- --------------------------------------------------------------------------- --- expanding environment variables in the package configuration - -expandEnvVars :: String -> Force -> IO String -expandEnvVars str0 force = go str0 "" - where - go "" acc = return $! reverse acc - go ('$':'{':str) acc | (var, '}':rest) <- break close str - = do value <- lookupEnvVar var - go rest (reverse value ++ acc) - where close c = c == '}' || c == '\n' -- don't span newlines - go (c:str) acc - = go str (c:acc) - - lookupEnvVar :: String -> IO String - lookupEnvVar nm = - catch (System.Environment.getEnv nm) - (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ - show nm) - return "") - ------------------------------------------------------------------------------ - -getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName - where str `withoutSuffix` suff - | suff `isSuffixOf` str = take (length str - length suff) str - | otherwise = str - -bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess - -die :: String -> IO a -die = dieWith 1 - -dieWith :: Int -> String -> IO a -dieWith ec s = do - hFlush stdout - prog <- getProgramName - hPutStrLn stderr (prog ++ ": " ++ s) - exitWith (ExitFailure ec) - -dieOrForceAll :: Force -> String -> IO () -dieOrForceAll ForceAll s = ignoreError s -dieOrForceAll _other s = dieForcible s - -ignoreError :: String -> IO () -ignoreError s = reportError (s ++ " (ignoring)") - -reportError :: String -> IO () -reportError s = do hFlush stdout; hPutStrLn stderr s - -dieForcible :: String -> IO () -dieForcible s = die (s ++ " (use --force to override)") - -my_head :: String -> [a] -> a -my_head s [] = error s -my_head _ (x : _) = x - ------------------------------------------ --- Cut and pasted from ghc/compiler/main/SysTools - -#if defined(mingw32_HOST_OS) -subst :: Char -> Char -> String -> String -subst a b ls = map (\ x -> if x == a then b else x) ls - -unDosifyPath :: FilePath -> FilePath -unDosifyPath xs = subst '\\' '/' xs - -getExecDir :: String -> IO (Maybe String) --- (getExecDir cmd) returns the directory in which the current --- executable, which should be called 'cmd', is running --- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, --- you'll get "/a/b/c" back as the result -getExecDir cmd - = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else do s <- peekCString buf - return (Just (reverse (drop (length cmd) - (reverse (unDosifyPath s))))) - where - len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 -#else -getExecDir :: String -> IO (Maybe String) -getExecDir _ = return Nothing -#endif - ------------------------------------------ --- Adapted from ghc/compiler/utils/Panic - -installSignalHandlers :: IO () -installSignalHandlers = do - threadid <- myThreadId - let - interrupt = Exception.throwTo threadid - (Exception.ErrorCall "interrupted") - -- -#if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing - installHandler sigINT (Catch interrupt) Nothing - return () -#elif __GLASGOW_HASKELL__ >= 603 - -- GHC 6.3+ has support for console events on Windows - -- NOTE: running GHCi under a bash shell for some reason requires - -- you to press Ctrl-Break rather than Ctrl-C to provoke - -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know - -- why --SDM 17/12/2004 - let sig_handler ControlC = interrupt - sig_handler Break = interrupt - sig_handler _ = return () - - installHandler (Catch sig_handler) - return () -#else - return () -- nothing -#endif - -#if __GLASGOW_HASKELL__ <= 604 -isInfixOf :: (Eq a) => [a] -> [a] -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -#endif - -#if mingw32_HOST_OS || mingw32_TARGET_OS -throwIOIO :: Exception.IOException -> IO a -throwIOIO = Exception.throwIO - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch -#endif - -catchError :: IO a -> (String -> IO a) -> IO a -catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err - - --- copied from Cabal's Distribution.Simple.Utils, except that we want --- to use text files here, rather than binary files. -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do - (newFile, newHandle) <- openNewFile targetDir template - do hPutStr newHandle content - hClose newHandle -#if mingw32_HOST_OS || mingw32_TARGET_OS - renameFile newFile targetFile - -- If the targetFile exists then renameFile will fail - `catchIO` \err -> do - exists <- doesFileExist targetFile - if exists - then do removeFile targetFile - -- Big fat hairy race condition - renameFile newFile targetFile - -- If the removeFile succeeds and the renameFile fails - -- then we've lost the atomic property. - else throwIOIO err -#else - renameFile newFile targetFile -#endif - `Exception.onException` do hClose newHandle - removeFile newFile - where - template = targetName <.> "tmp" - targetDir | null targetDir_ = "." - | otherwise = targetDir_ - --TODO: remove this when takeDirectory/splitFileName is fixed - -- to always return a valid dir - (targetDir_,targetName) = splitFileName targetFile - --- Ugh, this is a copy/paste of code from the base library, but --- if uses 666 rather than 600 for the permissions. -openNewFile :: FilePath -> String -> IO (FilePath, Handle) -openNewFile dir template = do - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL - - findTempName x = do - fd <- withCString filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- -#if __GLASGOW_HASKELL__ >= 609 - fdToHandle fd -#else - fdToHandle (fromIntegral fd) -#endif - `Exception.onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - --- XXX Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR - --- | The function splits the given string to substrings --- using 'isSearchPathSeparator'. -parseSearchPath :: String -> [FilePath] -parseSearchPath path = split path - where - split :: String -> [String] - split s = - case rest' of - [] -> [chunk] - _:rest -> chunk : split rest - where - chunk = - case chunk' of -#ifdef mingw32_HOST_OS - ('\"':xs@(_:_)) | last xs == '\"' -> init xs -#endif - _ -> chunk' - - (chunk', rest') = break isSearchPathSeparator s +module Main where + +import System.Cmd +import System.Environment +import System.FilePath +import System.Directory +import System.Info +import System.Exit +import Data.Version as Version +import Paths_lhc + +main :: IO () +main = do pkgConf <- getPkgConf + args <- getArgs + case args of + ["--version"] -> putStrLn $ "LHC package manager version " ++ Version.showVersion version + _other -> exitWith =<< system (unwords (["ghc-pkg"]++ args ++ + ["--package-conf=" ++ pkgConf + ,"--global-conf=" ++ pkgConf + ,"--no-user-package-conf"])) + +getPkgConf + = do appdir <- getAppUserDataDirectory "lhc" + let targetARCH = arch + targetOS = os + let subdir = targetARCH ++ '-':targetOS ++ '-':Version.showVersion version + return (appdir subdir "package.conf.d") diff --git a/lhc-regress/Main.hs b/lhc-regress/Main.hs --- a/lhc-regress/Main.hs +++ b/lhc-regress/Main.hs @@ -1,168 +1,19 @@ -{-# LANGUAGE CPP #-} module Main where -import Setup -import TestCase - -import System.Environment -import System.Process -import System.FilePath -import System.IO -import System.Exit -import System.Directory -import Control.Monad -import Control.Exception.Extensible -import System.Timeout -import Control.Concurrent -import Text.Printf -import qualified Data.ByteString.Char8 as B - -data TestResult = CompileError String - | ProgramError String String - | KnownFailure - | TimeOut - | Success - deriving Show - -isSuccess Success = True -isSuccess KnownFailure = True -isSuccess _ = False - -data Stats = Stats { successfulTests :: Int - , expectedFailures :: Int - , unexpectedFailures :: Int - , testsNotExecuted :: Int - } - -newStats :: Int -> Stats -newStats nTests = Stats 0 0 0 nTests - -successfulTest :: Stats -> Stats -successfulTest stats = stats{ successfulTests = successfulTests stats + 1 - , testsNotExecuted = testsNotExecuted stats - 1 } - -expectedFailure :: Stats -> Stats -expectedFailure stats = stats{ expectedFailures = expectedFailures stats + 1 - , testsNotExecuted = testsNotExecuted stats - 1 } - -unexpectedFailure :: Stats -> Stats -unexpectedFailure stats = stats{ unexpectedFailures = unexpectedFailures stats + 1 - , testsNotExecuted = testsNotExecuted stats - 1 } - -hasFailures :: Stats -> Bool -hasFailures stats = unexpectedFailures stats /= 0 - -ppStats :: Stats -> String -ppStats stats = printf ("Successful tests: %d\n"++ - "Expected failures: %d\n"++ - "Unexpected failures: %d\n"++ - "Omitted tests: %d\n") - (successfulTests stats) - (expectedFailures stats) - (unexpectedFailures stats) - (testsNotExecuted stats) - -updateStats :: TestResult -> Stats -> Stats -updateStats Success = successfulTest -updateStats KnownFailure = expectedFailure -updateStats _ = unexpectedFailure - -main :: IO () -main = do (cfg,paths) <- parseArguments =<< getArgs - workChan <- newChan - resultChan <- newChan - tests <- forM paths findTestCases - let nTests = length (concat tests) - writeList2Chan workChan (concat tests) - when (cfgVerbose cfg >= 1) $ putStrLn $ "Testsuite consists of " ++ show nTests ++ " tests." - workers <- replicateM (max 1 (cfgThreads cfg)) $ forkIO $ forever $ - do test <- readChan workChan - result <- runTestCase cfg test - writeChan resultChan (test,result) - - results <- getChanContents resultChan - manager cfg (newStats nTests) (take nTests results) - `finally` mapM_ killThread workers - - -errMsg = "Some tests failed to perform as expected." - -manager cfg stats rest | hasFailures stats && (not (cfgComplete cfg) || null rest) - = do when (cfgVerbose cfg == 1) $ putStrLn "" - when (cfgVerbose cfg >= 1) $ do putStrLn errMsg - putStr (ppStats stats) - exitFailure - -manager cfg stats [] | cfgVerbose cfg >= 3 = do putStrLn "No unexpected failures" - putStr (ppStats stats) -manager cfg stats [] | cfgVerbose cfg >= 1 = do putStrLn "" - putStr (ppStats stats) -manager cfg stats [] = return () +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) -manager cfg stats ((tc,result):rest) - = do case () of () | cfgVerbose cfg >= 3 -> case result of - Success -> printf "%20s: %s\n" (testCaseName tc) "OK." - KnownFailure -> printf "%20s: %s\n" (testCaseName tc) "Known failure." - TimeOut -> printf "%20s: %s\n" (testCaseName tc) "TimeOut." - CompileError str | cfgVerbose cfg >= 4 -> printf "%20s: %s\n" (testCaseName tc) str - ProgramError short str | cfgVerbose cfg >= 4 -> printf "%20s: %s:\n%s" (testCaseName tc) short str - CompileError str -> printf "%20s: %s\n" (testCaseName tc) "Compile failure." - ProgramError short str -> printf "%20s: %s\n" (testCaseName tc) short - | cfgVerbose cfg >= 1 -> if isSuccess result then putStr "." else putStr "*" - | otherwise -> return () - hFlush stdout - manager cfg (updateStats result stats) rest +import Test.QuickCheck +import Test.HUnit --- FIXME: Get a proper temporary directory. -runTestCase :: Config -> TestCase -> IO TestResult -runTestCase cfg tc - = bracket (createDirectoryIfMissing True testDir) - (\_ -> removeDirectoryRecursive testDir) $ \_ -> checkFail $ withTimeout $ - do let args = [ "eval" - , testCasePath tc `replaceExtension` "hcr" ] ++ - cfgLHCOptions cfg ++ - testCaseArgs tc - ghcArgs = ["-fforce-recomp","-fext-core","-O2","-c",testCasePath tc] - when (cfgVerbose cfg >= 4) $ putStrLn $ unwords ("ghc":ghcArgs) - (ret,out,err) <- execProcess "lhc" ghcArgs B.empty - case ret of - ExitFailure c -> return $ CompileError $ unlines $ ["ghc failed with: " ++ show c, B.unpack err] - ExitSuccess - -> do when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (cfgLHCPath cfg:args) - (ret,out,err) <- execProcess (cfgLHCPath cfg) args B.empty - case (testCaseStdout tc, testCaseStderr tc) of - (Just expectedOut,_) | expectedOut /= out -> return $ ProgramError "Unexpected stdout" $ B.unpack out - (_,Just expectedErr) | expectedErr /= err -> return $ ProgramError "Unexpected stderr" $ B.unpack err - _ -> return Success - where name = dropExtension (takeFileName (testCasePath tc)) - testDir = cfgTempDir cfg name - progName = testDir name - checkFail io = do ret <- io - if testCaseMustFail tc - then case ret of - Success -> return $ ProgramError "Known bug succeeded." "" - other -> return KnownFailure - else return ret - withTimeout io = do ret <- timeout (10^6 * cfgTestTimeout cfg) io - case ret of - Nothing -> return TimeOut - Just val -> return val +import Data.List --- This differs from System.Process by terminating the program if an exception is raised. -execProcess :: FilePath -> [String] -> B.ByteString -> IO (ExitCode, B.ByteString, B.ByteString) -execProcess cmd args input = do - (inh, outh, errh, pid) <- runInteractiveProcess cmd args Nothing Nothing - handle (\e -> do terminateProcess pid - throw (e::SomeException)) $ do - outVar <- newEmptyMVar - forkIO $ B.hGetContents outh >>= putMVar outVar - errVar <- newEmptyMVar - forkIO $ B.hGetContents errh >>= putMVar errVar +import UnitTests +import Properties - when (not (B.null input)) $ do B.hPutStr inh input >> hFlush inh - hClose inh +main = defaultMain tests - out <- takeMVar outVar - err <- takeMVar errVar - ret <- waitForProcess pid - return (ret, out, err) +tests = [ testGroup "Unit tests" unitTests + , testGroup "Properties" properties + ] diff --git a/lhc-regress/Properties.hs b/lhc-regress/Properties.hs new file mode 100644 --- /dev/null +++ b/lhc-regress/Properties.hs @@ -0,0 +1,48 @@ +module Properties + ( properties + ) where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck (testProperty) +import Test.QuickCheck + +import Data.Monoid +import Control.Monad +import Grin.Types +import Grin.HPT.Environment as Env + +instance Arbitrary Rhs where + arbitrary = do rhsValues <- arbitrary + return $ mconcat (map singleton rhsValues) + +instance Arbitrary RhsValue where + arbitrary = oneof [ liftM3 Extract arbitrary arbitrary arbitrary + , liftM2 ExtractVector arbitrary arbitrary + , liftM Eval arbitrary + , liftM2 Env.Update arbitrary arbitrary + , liftM2 Apply arbitrary arbitrary + , liftM2 PartialApply arbitrary arbitrary + , liftM Ident arbitrary + , liftM Fetch arbitrary + , return Base + , liftM Heap arbitrary + , sized $ \n -> liftM4 Tag arbitrary arbitrary arbitrary (resize (n `div` 2) arbitrary) + , sized $ \n -> liftM VectorTag (resize (n `div` 2) arbitrary) + ] + +instance Arbitrary Renamed where + arbitrary = liftM Anonymous arbitrary + +instance Arbitrary NodeType where + arbitrary = elements [ ConstructorNode + , FunctionNode ] + + +properties + = [ testGroup "HPT" + [ testProperty "isSubsetOf" prop_isSubsetOf ] + ] + + +prop_isSubsetOf a b = a `isSubsetOf` b == (b == (a `mappend` b)) + diff --git a/lhc-regress/Setup.hs b/lhc-regress/Setup.hs deleted file mode 100644 --- a/lhc-regress/Setup.hs +++ /dev/null @@ -1,111 +0,0 @@ -module Setup - ( Config(..) - , parseArguments - ) where - -import System.Exit -import System.Environment -import System.Console.GetOpt -import System.Directory -import Data.Maybe -import Data.Char - -data Config = - Config { cfgShowMarginalCoverage :: Bool - , cfgVerbose :: Int - , cfgThreads :: Int - , cfgTimeLimit :: Maybe Int - , cfgTempDir :: FilePath - , cfgLHCPath :: FilePath - , cfgLHCOptions :: [String] - , cfgTestTimeout :: Int -- in seconds - , cfgComplete :: Bool - } deriving Show - - -emptyConfig :: IO Config -emptyConfig = do tmp <- getTemporaryDirectory - lhc <- findExecutable "lhc" - return Config { cfgShowMarginalCoverage = False - , cfgVerbose = 1 - , cfgThreads = 1 - , cfgTimeLimit = Nothing - , cfgTempDir = tmp - , cfgLHCPath = fromMaybe "lhc" lhc - , cfgLHCOptions = ["+RTS","-M1G","-RTS"] - , cfgTestTimeout = 60 - , cfgComplete = False} - -cmd_verbose :: OptDescr (Config -> Config) -cmd_verbose = Option "v" ["verbose"] (OptArg verboseFlag "n") - "Control verbosity (n is 0-5, normal verbosity level is 1, -v alone is equivalent to -v3)" - where - verboseFlag mb_s cfg = cfg{cfgVerbose = (maybe 3 read mb_s)} - -cmd_threads :: OptDescr (Config -> Config) -cmd_threads = Option "N" ["threads"] (ReqArg threadsFlag "n") - "Use OS threads (default: 1)" - where - threadsFlag s cfg = cfg{cfgThreads = read s } - -cmd_options :: OptDescr (Config -> Config) -cmd_options = Option "" ["lhc-options"] (ReqArg optionsFlag "OPTS") - "Give extra options to lhc" - where - optionsFlag s cfg = cfg{cfgLHCOptions = cfgLHCOptions cfg ++ words s} - -cmd_complete :: OptDescr (Config -> Config) -cmd_complete = Option "c" ["complete"] (OptArg completeFlag "BOOL") - "Run all tests even if some fail." - where - completeFlag mb_s cfg = cfg{cfgComplete = maybe True (parseBool . map toLower) mb_s} - -cmd_with_lhc :: OptDescr (Config -> Config) -cmd_with_lhc = Option "" ["with-lhc"] (ReqArg (\path cfg -> cfg{cfgLHCPath = path}) "PATH") - "Give the path to lhc." - -{- -cmd_dryrun :: OptDescr Flag -cmd_dryrun = Option "d" ["dry-run"] (OptArg dryrunFlag "bool") - "Dry run. Accept values in the line of 'false', '0' and 'no'. Default: false." - where - dryrunFlag mb_s = DryRun (maybe True (parse.map toLower) mb_s)-} - -parseBool "false" = False -parseBool "0" = False -parseBool "no" = False -parseBool _ = True - - -globalOptions :: [OptDescr (Config -> Config)] -globalOptions = - [-- cmd_help - cmd_verbose - , cmd_threads - , cmd_options - , cmd_complete - , cmd_with_lhc --- , cmd_dryrun - ] - - -printUsage = - do pname <- getProgName - let syntax_line = concat [ "Usage: ", pname - , " [FLAGS] [PATH]" - , "\n\nGlobal flags:"] - putStrLn (usageInfo syntax_line globalOptions) - where align n str = str ++ replicate (n - length str) ' ' - -parseArguments :: [String] -> IO (Config, [FilePath]) -parseArguments args - = case getOpt' Permute globalOptions args of - (flags,paths,[],[]) -> - do cfg <- emptyConfig - return (foldr (.) id flags cfg, if null paths then ["."] else paths) - (flags,paths,warns,[]) -> - do printUsage - exitWith ExitSuccess - (_,_,_,errs) -> - do putStrLn $ "Errors: \n" ++ unlines errs - exitFailure diff --git a/lhc-regress/TestCase.hs b/lhc-regress/TestCase.hs deleted file mode 100644 --- a/lhc-regress/TestCase.hs +++ /dev/null @@ -1,76 +0,0 @@ -module TestCase where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B - -import System.Directory -import System.FilePath -import Control.Monad - -{- - -A testcase is any Haskell file (.hs or .lhs) that has an associated -.expected.stdout or .expected.stderr file. - --} - -data TestCase = TestCase { testCasePath :: String - , testCaseStdin :: ByteString - , testCaseStdout :: Maybe ByteString - , testCaseStderr :: Maybe ByteString - , testCaseArgs :: [String] - , testCaseMustFail :: Bool - } deriving Show - - -findTestCases :: FilePath -> IO [TestCase] -findTestCases root - = do contents <- getDirectoryContents root - let walker acc [] = return acc - walker acc (c:cs) | c `elem` [".",".."] = walker acc cs - walker acc (c:cs) - = do isDir <- doesDirectoryExist (root c) - if isDir - then do --putStrLn $ "Recursing: " ++ root c - sub <- findTestCases (root c) - walker (sub++acc) cs - else do --putStrLn $ "Looking at: " ++ root c - mbTest <- getTestCase (root c) - case mbTest of - Nothing -> walker acc cs - Just test -> walker (test:acc) cs - walker [] contents - - -getTestCase :: FilePath -> IO (Maybe TestCase) -getTestCase path | takeExtension path `elem` [".hs",".lhs"] - = do isValid <- liftM2 (||) (doesFileExist stdoutFile) - (doesFileExist stderrFile) - if isValid - then do stdin <- B.readFile stdinFile `orElse` return B.empty - stdout <- fmap Just (B.readFile stdoutFile) `orElse` return Nothing - stderr <- fmap Just (B.readFile stderrFile) `orElse` return Nothing - args <- fmap words (readFile argsFile) `orElse` return [] -- FIXME: Use unlines? - mustFail <- doesFileExist mustFailFile - return $ Just TestCase { testCasePath = path - , testCaseStdin = stdin - , testCaseStdout = stdout - , testCaseStderr = stderr - , testCaseArgs = args - , testCaseMustFail = mustFail } - else return Nothing - where root = takeDirectory path - name = dropExtension (takeFileName path) - stdinFile = root name <.> "stdin" - stdoutFile = root name <.> "expected.stdout" - stderrFile = root name <.> "expected.stderr" - argsFile = root name <.> "args" - mustFailFile = root name <.> "mustfail" -getTestCase _ = return Nothing - -testCaseRoot = takeDirectory . testCasePath -testCaseName = dropExtension . takeFileName . testCasePath - -a `orElse` b = a `catch` \_e -> b - - diff --git a/lhc.cabal b/lhc.cabal --- a/lhc.cabal +++ b/lhc.cabal @@ -1,131 +1,111 @@ cabal-version: >= 1.6 name: lhc -version: 0.8 +version: 0.10 synopsis: LHC Haskell Compiler description: lhc is a haskell compiler which aims to produce the most efficient programs possible via whole program analysis and other optimizations. -Tested-With: GHC == 6.10.1 +Tested-With: GHC == 6.12.2 category: Compiler license: PublicDomain -author: David Himmelstrup +author: David Himmelstrup, Austin Seipp maintainer: lhc@projects.haskell.org homepage: http://lhc.seize.it/ build-type: Custom -data-files: +extra-source-files: lib/base/base.cabal lib/base/includes/CTypes.h lib/base/includes/ieee-flpt.h lib/base/includes/Typeable.h lib/base/LICENSE - lib/base/Setup.lhs - lib/base/src/Control/Exception/Base.hs - lib/base/src/Control/Exception.hs - lib/base/src/Control/Monad.hs - lib/base/src/Data/Bits.hs - lib/base/src/Data/Char.hs - lib/base/src/Data/Dynamic.hs - lib/base/src/Data/Either.hs - lib/base/src/Data/HashTable.hs - lib/base/src/Data/Int.hs - lib/base/src/Data/IORef.hs - lib/base/src/Data/Ix.hs - lib/base/src/Data/List.hs - lib/base/src/Data/Maybe.hs - lib/base/src/Data/Tuple.hs - lib/base/src/Data/Typeable.hs - lib/base/src/Data/Typeable.hs-boot - lib/base/src/Data/Word.hs - lib/base/src/Foreign/C/Error.hsc - lib/base/src/Foreign/C/String.hs - lib/base/src/Foreign/C/Types.hs - lib/base/src/Foreign/C.hs - lib/base/src/Foreign/ForeignPtr.hs - lib/base/src/Foreign/Marshal/Alloc.hs - lib/base/src/Foreign/Marshal/Array.hs - lib/base/src/Foreign/Marshal/Error.hs - lib/base/src/Foreign/Marshal/Pool.hs - lib/base/src/Foreign/Marshal/Utils.hs - lib/base/src/Foreign/Marshal.hs - lib/base/src/Foreign/Ptr.hs - lib/base/src/Foreign/StablePtr.hs - lib/base/src/Foreign/Storable.hs - lib/base/src/Foreign/Storable.hs-boot - lib/base/src/Foreign.hs - lib/base/src/GHC/Arr.lhs - lib/base/src/GHC/Base.lhs - lib/base/src/GHC/Classes.hs - lib/base/src/GHC/Conc.lhs - lib/base/src/GHC/Enum.lhs - lib/base/src/GHC/Err.lhs - lib/base/src/GHC/Err.lhs-boot - lib/base/src/GHC/Exception.lhs - lib/base/src/GHC/Float.lhs - lib/base/src/GHC/ForeignPtr.hs - lib/base/src/GHC/Handle.hs - lib/base/src/GHC/Handle.hs-boot - lib/base/src/GHC/Int.hs - lib/base/src/GHC/IO.hs - lib/base/src/GHC/IOBase.lhs - lib/base/src/GHC/List.lhs - lib/base/src/GHC/Num.lhs - lib/base/src/GHC/Pack.lhs - lib/base/src/GHC/Ptr.lhs - lib/base/src/GHC/Read.lhs - lib/base/src/GHC/Real.lhs - lib/base/src/GHC/Show.lhs - lib/base/src/GHC/ST.lhs - lib/base/src/GHC/Stable.lhs - lib/base/src/GHC/Storable.lhs - lib/base/src/GHC/STRef.lhs - lib/base/src/GHC/TopHandler.lhs - lib/base/src/GHC/Unicode.hs - lib/base/src/GHC/Unicode.hs-boot - lib/base/src/GHC/Word.hs - lib/base/src/Numeric.hs - lib/base/src/Prelude.hs - lib/base/src/Prelude.hs-boot - lib/base/src/System/Environment.hs - lib/base/src/System/IO/Error.hs - lib/base/src/System/IO/Unsafe.hs - lib/base/src/System/IO.hs - lib/base/src/System/Posix/Internals.hs - lib/base/src/System/Posix/Types.hs - lib/base/src/Text/ParserCombinators/ReadP.hs - lib/base/src/Text/ParserCombinators/ReadPrec.hs - lib/base/src/Text/Printf.hs - lib/base/src/Text/Read/Lex.hs - lib/base/src/Text/Read.hs - lib/base/src/Text/Show/Functions.hs - lib/base/src/Text/Show.hs - lib/base/src/Unsafe/Coerce.hs - lib/ghc-prim/cbits/longlong.c - lib/ghc-prim/GHC/Bool.hs - lib/ghc-prim/GHC/Generics.hs - lib/ghc-prim/GHC/IntWord32.hs - lib/ghc-prim/GHC/IntWord64.hs - lib/ghc-prim/GHC/Ordering.hs - lib/ghc-prim/GHC/Prim.hs - lib/ghc-prim/GHC/PrimopWrappers.hs - lib/ghc-prim/GHC/Tuple.hs - lib/ghc-prim/GHC/Types.hs - lib/ghc-prim/GHC/Unit.hs + lib/base/Setup.hs + lib/base/src/Control/Exception/*.hs + lib/base/src/Control/*.hs + lib/base/src/Control/Monad/*.hs + lib/base/src/Control/Monad/ST/*.hs + lib/base/src/Data/*.hs + lib/base/src/Data/STRef/*.hs + lib/base/src/Data/*.hs-boot + lib/base/src/Foreign/C/*.hsc + lib/base/src/Foreign/C/*.hs + lib/base/src/Foreign/*.hs + lib/base/src/Foreign/Marshal/*.hs + lib/base/src/Debug/*.hs + lib/base/src/*.hs + lib/base/src/GHC/*.lhs + lib/base/src/GHC/*.lhs-boot + lib/base/src/GHC/*.hs + lib/base/src/GHC/*.hs-boot + lib/base/src/GHC/IO/*.hs + lib/base/src/GHC/IO/*.hs-boot + lib/base/src/GHC/IO/Encoding/*.hs + lib/base/src/GHC/IO/Encoding/CodePage/*.hs + lib/base/src/GHC/IO/Handle/*.hs + lib/base/src/GHC/IO/Handle/*.hs-boot + + lib/base/src/System/*.hs + lib/base/src/System/Console/*.hs + lib/base/src/System/Mem/*.hs + lib/base/src/System/IO/*.hs + lib/base/src/System/Posix/*.hs + lib/base/src/Text/ParserCombinators/*.hs + lib/base/src/Text/*.hs + lib/base/src/Text/Read/*.hs + lib/base/src/Text/Show/*.hs + lib/base/src/Unsafe/*.hs + lib/ghc-prim/GHC/*.hs lib/ghc-prim/ghc-prim.cabal lib/ghc-prim/LICENSE lib/ghc-prim/Setup.hs - lib/integer-native/integer.cabal - lib/integer-native/LICENSE - lib/integer-native/Setup.lhs - lib/integer-native/src/GHC/Integer/Internals.hs - lib/integer-native/src/GHC/Integer.hs + lib/integer-ltm/integer.cabal + lib/integer-ltm/LICENSE + lib/integer-ltm/Setup.hs + lib/integer-ltm/src/GHC/Integer.hs + lib/integer-ltm/src/GHC/Integer/Ltm.hs + lib/integer-ltm/src/GHC/Integer/Type.hs + tests/1_io/basic/*.hs + tests/1_io/basic/*.args + tests/1_io/basic/*.expected.stdout + tests/1_io/basic/*.stdin + tests/2_language/*.hs + tests/2_language/*.expected.stdout + + tests/3_shootout/*.hs + tests/3_shootout/*.args + tests/3_shootout/*.expected.stdout + tests/3_shootout/*.mustfail + tests/3_shootout/*.stdin + + tests/9_nofib/*.hs + tests/9_nofib/*.expected.stdout + tests/9_nofib/spectral/calendar/*.hs + tests/9_nofib/spectral/calendar/*.expected.stdout + tests/9_nofib/spectral/calendar/*.args + tests/9_nofib/spectral/primes/*.hs + tests/9_nofib/spectral/primes/*.expected.stdout + + tests/bugs/*.hs + tests/bugs/*.expected.stdout + tests/bugs/*.mustfail + tests/bugs/*.args + +data-files: + rts/rts.ll + rts/rts.c + rts/ltm/*.c + rts/ltm/*.h + + flag hpc default: False flag threaded default: False flag lhc-regress default: False +flag lhc-pkg + default: True flag with-libs default: False @@ -136,16 +116,34 @@ ghc-prof-options: -auto-all build-depends: base >= 4 && < 5, mtl, bytestring, containers, ansi-wl-pprint, binary, digest, bytestring-trie, core >=0.5, filepath, directory, - derive, unix, libffi, xhtml, pretty, ghc >= 6.10 + derive, unix, xhtml, pretty, time, + parallel other-modules: Paths_lhc, LhcMain, CompactString, Traverse, Setup, Grin.Eval.Compile, Grin.Eval.Methods, Grin.Eval.Primitives, Grin.Eval.Types, Grin.FromCore, Grin.HPT.Environment, - Grin.HPT.Lower, Grin.HPT.Solve, Grin.HPT, - Grin.HtmlAnnotate, Grin.Lowering.Apply, + Grin.HPT.Lower, Grin.HPT.Solve, Grin.HPT, Grin.HPT.Interface, + Grin.HPT.FastSolve, + Grin.HPT.QuickSolve, + Grin.Lowering.Apply, Grin.Lowering.GHCism, Grin.Optimize.Simple, Grin.Pretty, + Grin.Optimize.Inline, + Grin.Optimize.Case, + Grin.Transform, + Grin.PreciseDeadCode, Grin.DeadCode, Grin.SimpleCore.DeadCode, Grin.SimpleCore.Types, - Grin.SimpleCore, Grin.Types + Grin.SimpleCore, Grin.Types, Manager, Grin.Stage2.Rename, + Grin.Stage2.DeadCode, + Grin.Stage2.Pretty, + Grin.Stage2.Transform, + Grin.Stage2.Types, + Grin.Stage2.Optimize.Case, + Grin.Stage2.Optimize.Simple, + Grin.Stage2.Backend.C, + Grin.Stage2.Backend.LLVM, + Grin.Stage2.FromStage1, + HashMap, + HashSet ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-incomplete-patterns Extensions: ScopedTypeVariables @@ -153,20 +151,31 @@ x-build-libs: True else x-build-libs: False + if flag(hpc) + ghc-options: -fhpc -hisuf hpc_hi -osuf hpc_o if flag(threaded) ghc-options: -threaded + if impl(ghc == 6.12.*) && arch(x86_64) + buildable: True + else + buildable: False Executable lhc-regress - if flag(lhc-regress) + if flag(lhc-regress) && impl(ghc == 6.12.*) && arch(x86_64) Buildable: True else Buildable: False main-is: Main.hs - other-modules: TestCase, Setup - hs-source-dirs: lhc-regress/ - build-depends: base >= 4 && < 5, process, extensible-exceptions + other-modules: UnitTests, Properties + hs-source-dirs: lhc-regress/ src/ tests/ + build-depends: base >= 4 && < 5, process, extensible-exceptions, HUnit, QuickCheck, test-framework, + test-framework-hunit, test-framework-quickcheck Executable lhc-pkg + if flag(lhc-pkg) && impl(ghc == 6.12.*) && arch(x86_64) + Buildable: True + else + Buildable: False hs-source-dirs: lhc-pkg/ main-is: Main.hs Extensions: CPP, ForeignFunctionInterface diff --git a/lib/base/Setup.hs b/lib/base/Setup.hs new file mode 100644 --- /dev/null +++ b/lib/base/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/lib/base/Setup.lhs b/lib/base/Setup.lhs deleted file mode 100644 --- a/lib/base/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/lib/base/base.cabal b/lib/base/base.cabal --- a/lib/base/base.cabal +++ b/lib/base/base.cabal @@ -13,87 +13,158 @@ Library { extensions: CPP, NoImplicitPrelude, MagicHash - build-depends: ghc-prim, integer + build-depends: ghc-prim, integer-gmp ghc-options: -package-name base -fglasgow-exts include-dirs: includes/ Exposed-modules: - Prelude - Data.List - Data.Ix - Data.Char - Data.Maybe - Data.Either - Data.Tuple - Data.Bits - Data.Word - Data.Int - Data.HashTable - Data.Typeable - Data.Dynamic - Data.IORef - Text.ParserCombinators.ReadP - Text.ParserCombinators.ReadPrec - Text.Read.Lex - Text.Show - Text.Read - Text.Printf --- Text.Show.Functions - Numeric - System.IO.Unsafe - System.IO.Error - System.IO - System.Posix.Types - System.Posix.Internals - System.Environment - - GHC.Base - GHC.Unicode - GHC.Read - GHC.Float - GHC.Arr - GHC.Classes - GHC.Exception - GHC.Err - GHC.List - GHC.Show - GHC.Enum - GHC.Num - GHC.ST - GHC.STRef - GHC.Word - GHC.Int - GHC.Real - GHC.Ptr - GHC.Stable - GHC.Storable - GHC.ForeignPtr - GHC.Pack - GHC.Conc - GHC.Handle - GHC.IO - GHC.TopHandler - GHC.IOBase - Unsafe.Coerce - Foreign.C.Types - Foreign.C.String - Foreign.C.Error - Foreign.C - Foreign.Ptr - Foreign.ForeignPtr - Foreign.StablePtr - Foreign.Storable - Foreign.Marshal.Alloc - Foreign.Marshal.Utils - Foreign.Marshal.Array - Foreign.Marshal.Error - Foreign.Marshal.Pool - Foreign.Marshal - Foreign +-- Foreign.Concurrent, + GHC.Arr, + GHC.Base, + GHC.Classes, + GHC.Conc, + GHC.ConsoleHandler, +-- GHC.Constants, + GHC.Desugar, + GHC.Enum, + GHC.Environment, + GHC.Err, + GHC.Exception, + GHC.Exts, + GHC.Float, + GHC.ForeignPtr, + GHC.MVar, + GHC.IO, + GHC.IO.IOMode, + GHC.IO.Buffer, + GHC.IO.Device, + GHC.IO.BufferedIO, + GHC.IO.FD, + GHC.IO.Exception, + GHC.IO.Encoding, + GHC.IO.Encoding.Latin1, + GHC.IO.Encoding.UTF8, + GHC.IO.Encoding.UTF16, + GHC.IO.Encoding.UTF32, + GHC.IO.Encoding.Types, + GHC.IO.Encoding.Iconv, + GHC.IO.Encoding.CodePage, + GHC.IO.Handle, + GHC.IO.Handle.Types, + GHC.IO.Handle.Internals, + GHC.IO.Handle.FD, + GHC.IO.Handle.Text, + GHC.IOBase, + GHC.Handle, + GHC.IORef, + GHC.IOArray, + GHC.Int, + GHC.List, + GHC.Num, + GHC.PArr, + GHC.Pack, + GHC.Ptr, + GHC.Read, + GHC.Real, + GHC.ST, + GHC.STRef, + GHC.Show, + GHC.Stable, + GHC.Storable, + GHC.TopHandler, + GHC.Unicode, + GHC.Weak, + GHC.Word, +-- System.Timeout, - Control.Monad - Control.Exception.Base - Control.Exception + Control.Applicative, + Control.Arrow, + Control.Category, +-- Control.Concurrent, +-- Control.Concurrent.Chan, +-- Control.Concurrent.MVar, +-- Control.Concurrent.QSem, +-- Control.Concurrent.QSemN, +-- Control.Concurrent.SampleVar, + Control.Exception, + Control.Exception.Base + Control.OldException, + Control.Monad, + Control.Monad.Fix, + Control.Monad.Instances, + Control.Monad.ST + Control.Monad.ST.Lazy + Control.Monad.ST.Strict + Data.Bits, + Data.Bool, + Data.Char, + Data.Complex, + Data.Dynamic, + Data.Either, + Data.Eq, + Data.Data, + Data.Fixed, + Data.Foldable + Data.Function, + Data.Functor, + Data.HashTable, + Data.IORef, + Data.Int, + Data.Ix, + Data.List, + Data.Maybe, + Data.Monoid, + Data.Ord, + Data.Ratio, + Data.STRef + Data.STRef.Lazy + Data.STRef.Strict + Data.String, + Data.Traversable + Data.Tuple, + Data.Typeable, +-- Data.Unique, + Data.Version, + Data.Word, + Debug.Trace, + Foreign, + Foreign.C, + Foreign.C.Error, + Foreign.C.String, + Foreign.C.Types, + Foreign.ForeignPtr, + Foreign.Marshal, + Foreign.Marshal.Alloc, + Foreign.Marshal.Array, + Foreign.Marshal.Error, + Foreign.Marshal.Pool, + Foreign.Marshal.Utils, + Foreign.Ptr, + Foreign.StablePtr, + Foreign.Storable, + Numeric, + Prelude, +-- System.Info + System.Console.GetOpt +-- System.CPUTime, + System.Environment, + System.Exit, + System.IO, + System.IO.Error, + System.IO.Unsafe, + System.Mem, + System.Mem.StableName, + System.Mem.Weak, + System.Posix.Internals, + System.Posix.Types, + Text.ParserCombinators.ReadP, + Text.ParserCombinators.ReadPrec, + Text.Printf, + Text.Read, + Text.Read.Lex, + Text.Show, + Text.Show.Functions + Unsafe.Coerce Hs-source-dirs: src } diff --git a/lib/base/src/Control/Applicative.hs b/lib/base/src/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Applicative.hs @@ -0,0 +1,227 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This module describes a structure intermediate between a functor and +-- a monad: it provides pure expressions and sequencing, but no binding. +-- (Technically, a strong lax monoidal functor.) For more details, see +-- /Applicative Programming with Effects/, +-- by Conor McBride and Ross Paterson, online at +-- . +-- +-- This interface was introduced for parsers by Niklas Röjemo, because +-- it admits more sharing than the monadic interface. The names here are +-- mostly based on recent parsing work by Doaitse Swierstra. +-- +-- This class is also useful with instances of the +-- 'Data.Traversable.Traversable' class. + +module Control.Applicative ( + -- * Applicative functors + Applicative(..), + -- * Alternatives + Alternative(..), + -- * Instances + Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..), + -- * Utility functions + (<$>), (<$), (<**>), + liftA, liftA2, liftA3, + optional, + ) where + +import Prelude hiding (id,(.)) + +import Control.Category +import Control.Arrow + (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>))) +import Control.Monad (liftM, ap, MonadPlus(..)) +import Control.Monad.Instances () +import Data.Functor ((<$>), (<$)) +import Data.Monoid (Monoid(..)) + +infixl 3 <|> +infixl 4 <*>, <*, *>, <**> + +-- | A functor with application. +-- +-- Instances should satisfy the following laws: +-- +-- [/identity/] +-- @'pure' 'id' '<*>' v = v@ +-- +-- [/composition/] +-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@ +-- +-- [/homomorphism/] +-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@ +-- +-- [/interchange/] +-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@ +-- +-- [/ignore left value/] +-- @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@ +-- +-- [/ignore right value/] +-- @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@ +-- +-- The 'Functor' instance should satisfy +-- +-- @ +-- 'fmap' f x = 'pure' f '<*>' x +-- @ +-- +-- If @f@ is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@. +-- +-- Minimal complete definition: 'pure' and '<*>'. + +class Functor f => Applicative f where + -- | Lift a value. + pure :: a -> f a + + -- | Sequential application. + (<*>) :: f (a -> b) -> f a -> f b + + -- | Sequence actions, discarding the value of the first argument. + (*>) :: f a -> f b -> f b + (*>) = liftA2 (const id) + + -- | Sequence actions, discarding the value of the second argument. + (<*) :: f a -> f b -> f a + (<*) = liftA2 const + +-- | A monoid on applicative functors. +-- +-- Minimal complete definition: 'empty' and '<|>'. +-- +-- 'some' and 'many' should be the least solutions of the equations: +-- +-- * @some v = (:) '<$>' v '<*>' many v@ +-- +-- * @many v = some v '<|>' 'pure' []@ +class Applicative f => Alternative f where + -- | The identity of '<|>' + empty :: f a + -- | An associative binary operation + (<|>) :: f a -> f a -> f a + + -- | One or more. + some :: f a -> f [a] + some v = some_v + where many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + + -- | Zero or more. + many :: f a -> f [a] + many v = many_v + where many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + +-- instances for Prelude types + +instance Applicative Maybe where + pure = return + (<*>) = ap + +instance Alternative Maybe where + empty = Nothing + Nothing <|> p = p + Just x <|> _ = Just x + +instance Applicative [] where + pure = return + (<*>) = ap + +instance Alternative [] where + empty = [] + (<|>) = (++) + +instance Applicative IO where + pure = return + (<*>) = ap + +instance Applicative ((->) a) where + pure = const + (<*>) f g x = f x (g x) + +instance Monoid a => Applicative ((,) a) where + pure x = (mempty, x) + (u, f) <*> (v, x) = (u `mappend` v, f x) + +-- new instances + +newtype Const a b = Const { getConst :: a } + +instance Functor (Const m) where + fmap _ (Const v) = Const v + +instance Monoid m => Applicative (Const m) where + pure _ = Const mempty + Const f <*> Const v = Const (f `mappend` v) + +newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } + +instance Monad m => Functor (WrappedMonad m) where + fmap f (WrapMonad v) = WrapMonad (liftM f v) + +instance Monad m => Applicative (WrappedMonad m) where + pure = WrapMonad . return + WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) + +instance MonadPlus m => Alternative (WrappedMonad m) where + empty = WrapMonad mzero + WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) + +newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } + +instance Arrow a => Functor (WrappedArrow a b) where + fmap f (WrapArrow a) = WrapArrow (a >>> arr f) + +instance Arrow a => Applicative (WrappedArrow a b) where + pure x = WrapArrow (arr (const x)) + WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id)) + +instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where + empty = WrapArrow zeroArrow + WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) + +-- | Lists, but with an 'Applicative' functor based on zipping, so that +-- +-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ +-- +newtype ZipList a = ZipList { getZipList :: [a] } + +instance Functor ZipList where + fmap f (ZipList xs) = ZipList (map f xs) + +instance Applicative ZipList where + pure x = ZipList (repeat x) + ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) + +-- extra functions + +-- | A variant of '<*>' with the arguments reversed. +(<**>) :: Applicative f => f a -> f (a -> b) -> f b +(<**>) = liftA2 (flip ($)) + +-- | Lift a function to actions. +-- This function may be used as a value for `fmap` in a `Functor` instance. +liftA :: Applicative f => (a -> b) -> f a -> f b +liftA f a = pure f <*> a + +-- | Lift a binary function to actions. +liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c +liftA2 f a b = f <$> a <*> b + +-- | Lift a ternary function to actions. +liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d +liftA3 f a b c = f <$> a <*> b <*> c + +-- | One or none. +optional :: Alternative f => f a -> f (Maybe a) +optional v = Just <$> v <|> pure Nothing diff --git a/lib/base/src/Control/Arrow.hs b/lib/base/src/Control/Arrow.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Arrow.hs @@ -0,0 +1,275 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Arrow +-- Copyright : (c) Ross Paterson 2002 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Basic arrow definitions, based on +-- /Generalising Monads to Arrows/, by John Hughes, +-- /Science of Computer Programming/ 37, pp67-111, May 2000. +-- plus a couple of definitions ('returnA' and 'loop') from +-- /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/, +-- Firenze, Italy, pp229-240. +-- See these papers for the equations these combinators are expected to +-- satisfy. These papers and more information on arrows can be found at +-- . + +module Control.Arrow ( + -- * Arrows + Arrow(..), Kleisli(..), + -- ** Derived combinators + returnA, + (^>>), (>>^), + -- ** Right-to-left variants + (<<^), (^<<), + -- * Monoid operations + ArrowZero(..), ArrowPlus(..), + -- * Conditionals + ArrowChoice(..), + -- * Arrow application + ArrowApply(..), ArrowMonad(..), leftApp, + -- * Feedback + ArrowLoop(..), + + (>>>), (<<<) -- reexported + ) where + +import Prelude hiding (id,(.)) + +import Control.Monad +import Control.Monad.Fix +import Control.Category + +infixr 5 <+> +infixr 3 *** +infixr 3 &&& +infixr 2 +++ +infixr 2 ||| +infixr 1 ^>>, >>^ +infixr 1 ^<<, <<^ + +-- | The basic arrow class. +-- +-- Minimal complete definition: 'arr' and 'first'. +-- +-- The other combinators have sensible default definitions, +-- which may be overridden for efficiency. + +class Category a => Arrow a where + + -- | Lift a function to an arrow. + arr :: (b -> c) -> a b c + + -- | Send the first component of the input through the argument + -- arrow, and copy the rest unchanged to the output. + first :: a b c -> a (b,d) (c,d) + + -- | A mirror image of 'first'. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + second :: a b c -> a (d,b) (d,c) + second f = arr swap >>> first f >>> arr swap + where swap ~(x,y) = (y,x) + + -- | Split the input between the two argument arrows and combine + -- their output. Note that this is in general not a functor. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (***) :: a b c -> a b' c' -> a (b,b') (c,c') + f *** g = first f >>> second g + + -- | Fanout: send the input to both argument arrows and combine + -- their output. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (&&&) :: a b c -> a b c' -> a b (c,c') + f &&& g = arr (\b -> (b,b)) >>> f *** g + +{-# RULES +"compose/arr" forall f g . + (arr f) . (arr g) = arr (f . g) +"first/arr" forall f . + first (arr f) = arr (first f) +"second/arr" forall f . + second (arr f) = arr (second f) +"product/arr" forall f g . + arr f *** arr g = arr (f *** g) +"fanout/arr" forall f g . + arr f &&& arr g = arr (f &&& g) +"compose/first" forall f g . + (first f) . (first g) = first (f . g) +"compose/second" forall f g . + (second f) . (second g) = second (f . g) + #-} + +-- Ordinary functions are arrows. + +instance Arrow (->) where + arr f = f + first f = f *** id + second f = id *** f +-- (f *** g) ~(x,y) = (f x, g y) +-- sorry, although the above defn is fully H'98, nhc98 can't parse it. + (***) f g ~(x,y) = (f x, g y) + +-- | Kleisli arrows of a monad. + +newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } + +instance Monad m => Category (Kleisli m) where + id = Kleisli return + (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f) + +instance Monad m => Arrow (Kleisli m) where + arr f = Kleisli (return . f) + first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d)) + second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c)) + +-- | The identity arrow, which plays the role of 'return' in arrow notation. + +returnA :: Arrow a => a b b +returnA = arr id + +-- | Precomposition with a pure function. +(^>>) :: Arrow a => (b -> c) -> a c d -> a b d +f ^>> a = arr f >>> a + +-- | Postcomposition with a pure function. +(>>^) :: Arrow a => a b c -> (c -> d) -> a b d +a >>^ f = a >>> arr f + +-- | Precomposition with a pure function (right-to-left variant). +(<<^) :: Arrow a => a c d -> (b -> c) -> a b d +a <<^ f = a <<< arr f + +-- | Postcomposition with a pure function (right-to-left variant). +(^<<) :: Arrow a => (c -> d) -> a b c -> a b d +f ^<< a = arr f <<< a + +class Arrow a => ArrowZero a where + zeroArrow :: a b c + +instance MonadPlus m => ArrowZero (Kleisli m) where + zeroArrow = Kleisli (\_ -> mzero) + +class ArrowZero a => ArrowPlus a where + (<+>) :: a b c -> a b c -> a b c + +instance MonadPlus m => ArrowPlus (Kleisli m) where + Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x) + +-- | Choice, for arrows that support it. This class underlies the +-- @if@ and @case@ constructs in arrow notation. +-- Any instance must define 'left'. The other combinators have sensible +-- default definitions, which may be overridden for efficiency. + +class Arrow a => ArrowChoice a where + + -- | Feed marked inputs through the argument arrow, passing the + -- rest through unchanged to the output. + left :: a b c -> a (Either b d) (Either c d) + + -- | A mirror image of 'left'. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + right :: a b c -> a (Either d b) (Either d c) + right f = arr mirror >>> left f >>> arr mirror + where mirror (Left x) = Right x + mirror (Right y) = Left y + + -- | Split the input between the two argument arrows, retagging + -- and merging their outputs. + -- Note that this is in general not a functor. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c') + f +++ g = left f >>> right g + + -- | Fanin: Split the input between the two argument arrows and + -- merge their outputs. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (|||) :: a b d -> a c d -> a (Either b c) d + f ||| g = f +++ g >>> arr untag + where untag (Left x) = x + untag (Right y) = y + +{-# RULES +"left/arr" forall f . + left (arr f) = arr (left f) +"right/arr" forall f . + right (arr f) = arr (right f) +"sum/arr" forall f g . + arr f +++ arr g = arr (f +++ g) +"fanin/arr" forall f g . + arr f ||| arr g = arr (f ||| g) +"compose/left" forall f g . + left f . left g = left (f . g) +"compose/right" forall f g . + right f . right g = right (f . g) + #-} + +instance ArrowChoice (->) where + left f = f +++ id + right f = id +++ f + f +++ g = (Left . f) ||| (Right . g) + (|||) = either + +instance Monad m => ArrowChoice (Kleisli m) where + left f = f +++ arr id + right f = arr id +++ f + f +++ g = (f >>> arr Left) ||| (g >>> arr Right) + Kleisli f ||| Kleisli g = Kleisli (either f g) + +-- | Some arrows allow application of arrow inputs to other inputs. + +class Arrow a => ArrowApply a where + app :: a (a b c, b) c + +instance ArrowApply (->) where + app (f,x) = f x + +instance Monad m => ArrowApply (Kleisli m) where + app = Kleisli (\(Kleisli f, x) -> f x) + +-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise +-- to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad. + +newtype ArrowApply a => ArrowMonad a b = ArrowMonad (a () b) + +instance ArrowApply a => Monad (ArrowMonad a) where + return x = ArrowMonad (arr (\_ -> x)) + ArrowMonad m >>= f = ArrowMonad (m >>> + arr (\x -> let ArrowMonad h = f x in (h, ())) >>> + app) + +-- | Any instance of 'ArrowApply' can be made into an instance of +-- 'ArrowChoice' by defining 'left' = 'leftApp'. + +leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d) +leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) ||| + (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app + +-- | The 'loop' operator expresses computations in which an output value is +-- fed back as input, even though the computation occurs only once. +-- It underlies the @rec@ value recursion construct in arrow notation. + +class Arrow a => ArrowLoop a where + loop :: a (b,d) (c,d) -> a b c + +instance ArrowLoop (->) where + loop f b = let (c,d) = f (b,d) in c + +instance MonadFix m => ArrowLoop (Kleisli m) where + loop (Kleisli f) = Kleisli (liftM fst . mfix . f') + where f' x y = f (x, snd y) diff --git a/lib/base/src/Control/Category.hs b/lib/base/src/Control/Category.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Category.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Category +-- Copyright : (c) Ashley Yakeley 2007 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ashley@semantic.org +-- Stability : experimental +-- Portability : portable + +-- http://hackage.haskell.org/trac/ghc/ticket/1773 + +module Control.Category where + +import qualified Prelude + +infixr 9 . +infixr 1 >>>, <<< + +-- | A class for categories. +-- id and (.) must form a monoid. +class Category cat where + -- | the identity morphism + id :: cat a a + + -- | morphism composition + (.) :: cat b c -> cat a b -> cat a c + +{-# RULES +"identity/left" forall p . + id . p = p +"identity/right" forall p . + p . id = p +"association" forall p q r . + (p . q) . r = p . (q . r) + #-} + +instance Category (->) where + id = Prelude.id +#ifndef __HADDOCK__ +-- Haddock 1.x cannot parse this: + (.) = (Prelude..) +#endif + +-- | Right-to-left composition +(<<<) :: Category cat => cat b c -> cat a b -> cat a c +(<<<) = (.) + +-- | Left-to-right composition +(>>>) :: Category cat => cat a b -> cat b c -> cat a c +f >>> g = g . f diff --git a/lib/base/src/Control/Concurrent.hs b/lib/base/src/Control/Concurrent.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Concurrent.hs @@ -0,0 +1,643 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (concurrency) +-- +-- A common interface to a collection of useful concurrency +-- abstractions. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent ( + -- * Concurrent Haskell + + -- $conc_intro + + -- * Basic concurrency operations + + ThreadId, +#ifdef __GLASGOW_HASKELL__ + myThreadId, +#endif + + forkIO, +#ifdef __GLASGOW_HASKELL__ + killThread, + throwTo, +#endif + + -- * Scheduling + + -- $conc_scheduling + yield, -- :: IO () + + -- ** Blocking + + -- $blocking + +#ifdef __GLASGOW_HASKELL__ + -- ** Waiting + threadDelay, -- :: Int -> IO () + threadWaitRead, -- :: Int -> IO () + threadWaitWrite, -- :: Int -> IO () +#endif + + -- * Communication abstractions + + module Control.Concurrent.MVar, + module Control.Concurrent.Chan, + module Control.Concurrent.QSem, + module Control.Concurrent.QSemN, + module Control.Concurrent.SampleVar, + + -- * Merging of streams +#ifndef __HUGS__ + mergeIO, -- :: [a] -> [a] -> IO [a] + nmergeIO, -- :: [[a]] -> IO [a] +#endif + -- $merge + +#ifdef __GLASGOW_HASKELL__ + -- * Bound Threads + -- $boundthreads + rtsSupportsBoundThreads, + forkOS, + isCurrentThreadBound, + runInBoundThread, + runInUnboundThread +#endif + + -- * GHC's implementation of concurrency + + -- |This section describes features specific to GHC's + -- implementation of Concurrent Haskell. + + -- ** Haskell threads and Operating System threads + + -- $osthreads + + -- ** Terminating the program + + -- $termination + + -- ** Pre-emption + + -- $preemption + ) where + +import Prelude + +import Control.Exception.Base as Exception + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exception +import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield, + threadDelay, forkIO, childHandler ) +import qualified GHC.Conc +import GHC.IO ( IO(..), unsafeInterleaveIO ) +import GHC.IORef ( newIORef, readIORef, writeIORef ) +import GHC.Base + +import System.Posix.Types ( Fd ) +import Foreign.StablePtr +import Foreign.C.Types ( CInt ) +import Control.Monad ( when ) + +#ifdef mingw32_HOST_OS +import Foreign.C +import System.IO +#endif +#endif + +#ifdef __HUGS__ +import Hugs.ConcBase +#endif + +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Control.Concurrent.QSem +import Control.Concurrent.QSemN +import Control.Concurrent.SampleVar + +#ifdef __HUGS__ +type ThreadId = () +#endif + +{- $conc_intro + +The concurrency extension for Haskell is described in the paper +/Concurrent Haskell/ +. + +Concurrency is \"lightweight\", which means that both thread creation +and context switching overheads are extremely low. Scheduling of +Haskell threads is done internally in the Haskell runtime system, and +doesn't make use of any operating system-supplied thread packages. + +However, if you want to interact with a foreign library that expects your +program to use the operating system-supplied thread package, you can do so +by using 'forkOS' instead of 'forkIO'. + +Haskell threads can communicate via 'MVar's, a kind of synchronised +mutable variable (see "Control.Concurrent.MVar"). Several common +concurrency abstractions can be built from 'MVar's, and these are +provided by the "Control.Concurrent" library. +In GHC, threads may also communicate via exceptions. +-} + +{- $conc_scheduling + + Scheduling may be either pre-emptive or co-operative, + depending on the implementation of Concurrent Haskell (see below + for information related to specific compilers). In a co-operative + system, context switches only occur when you use one of the + primitives defined in this module. This means that programs such + as: + + +> main = forkIO (write 'a') >> write 'b' +> where write c = putChar c >> write c + + will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@, + instead of some random interleaving of @a@s and @b@s. In + practice, cooperative multitasking is sufficient for writing + simple graphical user interfaces. +-} + +{- $blocking +Different Haskell implementations have different characteristics with +regard to which operations block /all/ threads. + +Using GHC without the @-threaded@ option, all foreign calls will block +all other Haskell threads in the system, although I\/O operations will +not. With the @-threaded@ option, only foreign calls with the @unsafe@ +attribute will block all other threads. + +Using Hugs, all I\/O operations and foreign calls will block all other +Haskell threads. +-} + +#ifndef __HUGS__ +max_buff_size :: Int +max_buff_size = 1 + +mergeIO :: [a] -> [a] -> IO [a] +nmergeIO :: [[a]] -> IO [a] + +-- $merge +-- The 'mergeIO' and 'nmergeIO' functions fork one thread for each +-- input list that concurrently evaluates that list; the results are +-- merged into a single output list. +-- +-- Note: Hugs does not provide these functions, since they require +-- preemptive multitasking. + +mergeIO ls rs + = newEmptyMVar >>= \ tail_node -> + newMVar tail_node >>= \ tail_list -> + newQSem max_buff_size >>= \ e -> + newMVar 2 >>= \ branches_running -> + let + buff = (tail_list,e) + in + forkIO (suckIO branches_running buff ls) >> + forkIO (suckIO branches_running buff rs) >> + takeMVar tail_node >>= \ val -> + signalQSem e >> + return val + +type Buffer a + = (MVar (MVar [a]), QSem) + +suckIO :: MVar Int -> Buffer a -> [a] -> IO () + +suckIO branches_running buff@(tail_list,e) vs + = case vs of + [] -> takeMVar branches_running >>= \ val -> + if val == 1 then + takeMVar tail_list >>= \ node -> + putMVar node [] >> + putMVar tail_list node + else + putMVar branches_running (val-1) + (x:xs) -> + waitQSem e >> + takeMVar tail_list >>= \ node -> + newEmptyMVar >>= \ next_node -> + unsafeInterleaveIO ( + takeMVar next_node >>= \ y -> + signalQSem e >> + return y) >>= \ next_node_val -> + putMVar node (x:next_node_val) >> + putMVar tail_list next_node >> + suckIO branches_running buff xs + +nmergeIO lss + = let + len = length lss + in + newEmptyMVar >>= \ tail_node -> + newMVar tail_node >>= \ tail_list -> + newQSem max_buff_size >>= \ e -> + newMVar len >>= \ branches_running -> + let + buff = (tail_list,e) + in + mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >> + takeMVar tail_node >>= \ val -> + signalQSem e >> + return val + where + mapIO f xs = sequence (map f xs) +#endif /* __HUGS__ */ + +#ifdef __GLASGOW_HASKELL__ +-- --------------------------------------------------------------------------- +-- Bound Threads + +{- $boundthreads + #boundthreads# + +Support for multiple operating system threads and bound threads as described +below is currently only available in the GHC runtime system if you use the +/-threaded/ option when linking. + +Other Haskell systems do not currently support multiple operating system threads. + +A bound thread is a haskell thread that is /bound/ to an operating system +thread. While the bound thread is still scheduled by the Haskell run-time +system, the operating system thread takes care of all the foreign calls made +by the bound thread. + +To a foreign library, the bound thread will look exactly like an ordinary +operating system thread created using OS functions like @pthread_create@ +or @CreateThread@. + +Bound threads can be created using the 'forkOS' function below. All foreign +exported functions are run in a bound thread (bound to the OS thread that +called the function). Also, the @main@ action of every Haskell program is +run in a bound thread. + +Why do we need this? Because if a foreign library is called from a thread +created using 'forkIO', it won't have access to any /thread-local state/ - +state variables that have specific values for each OS thread +(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some +libraries (OpenGL, for example) will not work from a thread created using +'forkIO'. They work fine in threads created using 'forkOS' or when called +from @main@ or from a @foreign export@. + +In terms of performance, 'forkOS' (aka bound) threads are much more +expensive than 'forkIO' (aka unbound) threads, because a 'forkOS' +thread is tied to a particular OS thread, whereas a 'forkIO' thread +can be run by any OS thread. Context-switching between a 'forkOS' +thread and a 'forkIO' thread is many times more expensive than between +two 'forkIO' threads. + +Note in particular that the main program thread (the thread running +@Main.main@) is always a bound thread, so for good concurrency +performance you should ensure that the main thread is not doing +repeated communication with other threads in the system. Typically +this means forking subthreads to do the work using 'forkIO', and +waiting for the results in the main thread. + +-} + +-- | 'True' if bound threads are supported. +-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound' +-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will +-- fail. +--foreign import ccall rtsSupportsBoundThreads :: Bool +rtsSupportsBoundThreads :: Bool +rtsSupportsBoundThreads = False + + +{- | +Like 'forkIO', this sparks off a new thread to run the 'IO' +computation passed as the first argument, and returns the 'ThreadId' +of the newly created thread. + +However, 'forkOS' creates a /bound/ thread, which is necessary if you +need to call foreign (non-Haskell) libraries that make use of +thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads"). + +Using 'forkOS' instead of 'forkIO' makes no difference at all to the +scheduling behaviour of the Haskell runtime system. It is a common +misconception that you need to use 'forkOS' instead of 'forkIO' to +avoid blocking all the Haskell threads when making a foreign call; +this isn't the case. To allow foreign calls to be made without +blocking all the Haskell threads (with GHC), it is only necessary to +use the @-threaded@ option when linking your program, and to make sure +the foreign import is not marked @unsafe@. +-} + +forkOS :: IO () -> IO ThreadId + +foreign export ccall forkOS_entry + :: StablePtr (IO ()) -> IO () + +foreign import ccall "forkOS_entry" forkOS_entry_reimported + :: StablePtr (IO ()) -> IO () + +forkOS_entry :: StablePtr (IO ()) -> IO () +forkOS_entry stableAction = do + action <- deRefStablePtr stableAction + action + +foreign import ccall forkOS_createThread + :: StablePtr (IO ()) -> IO CInt + +failNonThreaded :: IO a +failNonThreaded = fail $ "RTS doesn't support multiple OS threads " + ++"(use ghc -threaded when linking)" + +forkOS action0 + | rtsSupportsBoundThreads = do + mv <- newEmptyMVar + b <- Exception.blocked + let + -- async exceptions are blocked in the child if they are blocked + -- in the parent, as for forkIO (see #1048). forkOS_createThread + -- creates a thread with exceptions blocked by default. + action1 | b = action0 + | otherwise = unblock action0 + + action_plus = Exception.catch action1 childHandler + + entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus) + err <- forkOS_createThread entry + when (err /= 0) $ fail "Cannot create OS thread." + tid <- takeMVar mv + freeStablePtr entry + return tid + | otherwise = failNonThreaded + +-- | Returns 'True' if the calling thread is /bound/, that is, if it is +-- safe to use foreign libraries that rely on thread-local state from the +-- calling thread. +isCurrentThreadBound :: IO Bool +isCurrentThreadBound = IO $ \ s# -> + case isCurrentThreadBound# s# of + (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) + + +{- | +Run the 'IO' computation passed as the first argument. If the calling thread +is not /bound/, a bound thread is created temporarily. @runInBoundThread@ +doesn't finish until the 'IO' computation finishes. + +You can wrap a series of foreign function calls that rely on thread-local state +with @runInBoundThread@ so that you can use them without knowing whether the +current thread is /bound/. +-} +runInBoundThread :: IO a -> IO a + +runInBoundThread action + | rtsSupportsBoundThreads = do + bound <- isCurrentThreadBound + if bound + then action + else do + ref <- newIORef undefined + let action_plus = Exception.try action >>= writeIORef ref + resultOrException <- + bracket (newStablePtr action_plus) + freeStablePtr + (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) + case resultOrException of + Left exception -> Exception.throw (exception :: SomeException) + Right result -> return result + | otherwise = failNonThreaded + +{- | +Run the 'IO' computation passed as the first argument. If the calling thread +is /bound/, an unbound thread is created temporarily using 'forkIO'. +@runInBoundThread@ doesn't finish until the 'IO' computation finishes. + +Use this function /only/ in the rare case that you have actually observed a +performance loss due to the use of bound threads. A program that +doesn't need it's main thread to be bound and makes /heavy/ use of concurrency +(e.g. a web server), might want to wrap it's @main@ action in +@runInUnboundThread@. +-} +runInUnboundThread :: IO a -> IO a + +runInUnboundThread action = do + bound <- isCurrentThreadBound + if bound + then do + mv <- newEmptyMVar + b <- blocked + _ <- block $ forkIO $ + Exception.try (if b then action else unblock action) >>= + putMVar mv + takeMVar mv >>= \ei -> case ei of + Left exception -> Exception.throw (exception :: SomeException) + Right result -> return result + else action + +#endif /* __GLASGOW_HASKELL__ */ + +#ifdef __GLASGOW_HASKELL__ +-- --------------------------------------------------------------------------- +-- threadWaitRead/threadWaitWrite + +-- | Block the current thread until data is available to read on the +-- given file descriptor (GHC only). +threadWaitRead :: Fd -> IO () +threadWaitRead fd +#ifdef mingw32_HOST_OS + -- we have no IO manager implementing threadWaitRead on Windows. + -- fdReady does the right thing, but we have to call it in a + -- separate thread, otherwise threadWaitRead won't be interruptible, + -- and this only works with -threaded. + | threaded = withThread (waitFd fd 0) + | otherwise = case fd of + 0 -> do _ <- hWaitForInput stdin (-1) + return () + -- hWaitForInput does work properly, but we can only + -- do this for stdin since we know its FD. + _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" +#else + = GHC.Conc.threadWaitRead fd +#endif + +-- | Block the current thread until data can be written to the +-- given file descriptor (GHC only). +threadWaitWrite :: Fd -> IO () +threadWaitWrite fd +#ifdef mingw32_HOST_OS + | threaded = withThread (waitFd fd 1) + | otherwise = error "threadWaitWrite requires -threaded on Windows" +#else + = GHC.Conc.threadWaitWrite fd +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +withThread :: IO a -> IO a +withThread io = do + m <- newEmptyMVar + _ <- block $ forkIO $ try io >>= putMVar m + x <- takeMVar m + case x of + Right a -> return a + Left e -> throwIO (e :: IOException) + +waitFd :: Fd -> CInt -> IO () +waitFd fd write = do + throwErrnoIfMinus1_ "fdReady" $ + fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0 + +iNFINITE :: CInt +iNFINITE = 0xFFFFFFFF -- urgh + +--foreign import ccall safe "fdReady" +-- fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + +fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt +fdReady _ _ _ _ = return 1 + +#endif + +-- --------------------------------------------------------------------------- +-- More docs + +{- $osthreads + + #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and + are managed entirely by the GHC runtime. Typically Haskell + threads are an order of magnitude or two more efficient (in + terms of both time and space) than operating system threads. + + The downside of having lightweight threads is that only one can + run at a time, so if one thread blocks in a foreign call, for + example, the other threads cannot continue. The GHC runtime + works around this by making use of full OS threads where + necessary. When the program is built with the @-threaded@ + option (to link against the multithreaded version of the + runtime), a thread making a @safe@ foreign call will not block + the other threads in the system; another OS thread will take + over running Haskell threads until the original call returns. + The runtime maintains a pool of these /worker/ threads so that + multiple Haskell threads can be involved in external calls + simultaneously. + + The "System.IO" library manages multiplexing in its own way. On + Windows systems it uses @safe@ foreign calls to ensure that + threads doing I\/O operations don't block the whole runtime, + whereas on Unix systems all the currently blocked I\/O requests + are managed by a single thread (the /IO manager thread/) using + @select@. + + The runtime will run a Haskell thread using any of the available + worker OS threads. If you need control over which particular OS + thread is used to run a given Haskell thread, perhaps because + you need to call a foreign library that uses OS-thread-local + state, then you need bound threads (see "Control.Concurrent#boundthreads"). + + If you don't use the @-threaded@ option, then the runtime does + not make use of multiple OS threads. Foreign calls will block + all other running Haskell threads until the call returns. The + "System.IO" library still does multiplexing, so there can be multiple + threads doing I\/O, and this is handled internally by the runtime using + @select@. +-} + +{- $termination + + In a standalone GHC program, only the main thread is + required to terminate in order for the process to terminate. + Thus all other forked threads will simply terminate at the same + time as the main thread (the terminology for this kind of + behaviour is \"daemonic threads\"). + + If you want the program to wait for child threads to + finish before exiting, you need to program this yourself. A + simple mechanism is to have each child thread write to an + 'MVar' when it completes, and have the main + thread wait on all the 'MVar's before + exiting: + +> myForkIO :: IO () -> IO (MVar ()) +> myForkIO io = do +> mvar <- newEmptyMVar +> forkIO (io `finally` putMVar mvar ()) +> return mvar + + Note that we use 'finally' from the + "Control.Exception" module to make sure that the + 'MVar' is written to even if the thread dies or + is killed for some reason. + + A better method is to keep a global list of all child + threads which we should wait for at the end of the program: + +> children :: MVar [MVar ()] +> children = unsafePerformIO (newMVar []) +> +> waitForChildren :: IO () +> waitForChildren = do +> cs <- takeMVar children +> case cs of +> [] -> return () +> m:ms -> do +> putMVar children ms +> takeMVar m +> waitForChildren +> +> forkChild :: IO () -> IO ThreadId +> forkChild io = do +> mvar <- newEmptyMVar +> childs <- takeMVar children +> putMVar children (mvar:childs) +> forkIO (io `finally` putMVar mvar ()) +> +> main = +> later waitForChildren $ +> ... + + The main thread principle also applies to calls to Haskell from + outside, using @foreign export@. When the @foreign export@ed + function is invoked, it starts a new main thread, and it returns + when this main thread terminates. If the call causes new + threads to be forked, they may remain in the system after the + @foreign export@ed function has returned. +-} + +{- $preemption + + GHC implements pre-emptive multitasking: the execution of + threads are interleaved in a random fashion. More specifically, + a thread may be pre-empted whenever it allocates some memory, + which unfortunately means that tight loops which do no + allocation tend to lock out other threads (this only seems to + happen with pathological benchmark-style code, however). + + The rescheduling timer runs on a 20ms granularity by + default, but this may be altered using the + @-i\@ RTS option. After a rescheduling + \"tick\" the running thread is pre-empted as soon as + possible. + + One final note: the + @aaaa@ @bbbb@ example may not + work too well on GHC (see Scheduling, above), due + to the locking on a 'System.IO.Handle'. Only one thread + may hold the lock on a 'System.IO.Handle' at any one + time, so if a reschedule happens while a thread is holding the + lock, the other thread won't be able to run. The upshot is that + the switch from @aaaa@ to + @bbbbb@ happens infrequently. It can be + improved by lowering the reschedule tick period. We also have a + patch that causes a reschedule whenever a thread waiting on a + lock is woken up, but haven't found it to be useful for anything + other than this example :-) +-} +#endif /* __GLASGOW_HASKELL__ */ diff --git a/lib/base/src/Control/Exception.hs b/lib/base/src/Control/Exception.hs --- a/lib/base/src/Control/Exception.hs +++ b/lib/base/src/Control/Exception.hs @@ -53,8 +53,8 @@ System.ExitCode(), -- instance Exception #endif - BlockedOnDeadMVar(..), - BlockedIndefinitely(..), + BlockedIndefinitelyOnMVar(..), + BlockedIndefinitelyOnSTM(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), @@ -138,7 +138,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +-- import GHC.IO hiding ( onException, finally ) import Data.Maybe #else import Prelude hiding (catch) diff --git a/lib/base/src/Control/Exception/Base.hs b/lib/base/src/Control/Exception/Base.hs --- a/lib/base/src/Control/Exception/Base.hs +++ b/lib/base/src/Control/Exception/Base.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} #include "Typeable.h" @@ -37,8 +36,8 @@ NestedAtomically(..), #endif - BlockedOnDeadMVar(..), - BlockedIndefinitely(..), + BlockedIndefinitelyOnMVar(..), + BlockedIndefinitelyOnSTM(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), @@ -106,10 +105,11 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +import GHC.IO hiding (finally,onException) +import GHC.IO.Exception +import GHC.Exception import GHC.Show -import GHC.IOBase -import GHC.Exception hiding ( Exception ) +-- import GHC.Exception hiding ( Exception ) import GHC.Conc #endif @@ -128,9 +128,8 @@ import Data.Maybe #ifdef __NHC__ -import qualified System.IO.Error as H'98 (catch) -import System.IO.Error (ioError) -import IO (bracket) +import qualified IO as H'98 (catch) +import IO (bracket,ioError) import DIOError -- defn of IOError type import System (ExitCode()) import System.IO.Unsafe (unsafePerformIO) @@ -176,8 +175,8 @@ data PatternMatchFail data NoMethodError data Deadlock -data BlockedOnDeadMVar -data BlockedIndefinitely +data BlockedIndefinitelyOnMVar +data BlockedIndefinitelyOnSTM data ErrorCall data RecConError data RecSelError @@ -189,8 +188,8 @@ instance Show PatternMatchFail instance Show NoMethodError instance Show Deadlock -instance Show BlockedOnDeadMVar -instance Show BlockedIndefinitely +instance Show BlockedIndefinitelyOnMVar +instance Show BlockedIndefinitelyOnSTM instance Show ErrorCall instance Show RecConError instance Show RecSelError @@ -234,8 +233,8 @@ INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall") INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed") INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException") -INSTANCE_TYPEABLE0(BlockedOnDeadMVar,blockedOnDeadMVarTc,"BlockedOnDeadMVar") -INSTANCE_TYPEABLE0(BlockedIndefinitely,blockedIndefinitelyTc,"BlockedIndefinitely") +INSTANCE_TYPEABLE0(BlockedIndefinitelyOnMVar,blockedIndefinitelyOnMVarTc,"BlockedIndefinitelyOnMVar") +INSTANCE_TYPEABLE0(BlockedIndefinitelyOnSTM,blockedIndefinitelyOnSTM,"BlockedIndefinitelyOnSTM") INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock") instance Exception SomeException where @@ -272,8 +271,8 @@ fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s) fromException _ = Nothing -data BlockedOnDeadMVar = BlockedOnDeadMVar -data BlockedIndefinitely = BlockedIndefinitely +data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar +data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM data Deadlock = Deadlock data AssertionFailed = AssertionFailed String data AsyncException @@ -283,8 +282,8 @@ | UserInterrupt deriving (Eq, Ord) -instance Show BlockedOnDeadMVar where - showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" +instance Show BlockedIndefinitelyOnMVar where + showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely" instance Show BlockedIndefinitely where showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" @@ -340,8 +339,8 @@ -- -- Note that we have to give a type signature to @e@, or the program -- will not typecheck as the type is ambiguous. While it is possible --- to catch exceptions of any type, see $catchall for an explanation --- of the problems with doing so. +-- to catch exceptions of any type, see the previous section \"Catching all +-- exceptions\" for an explanation of the problems with doing so. -- -- For catching exceptions in pure (non-'IO') expressions, see the -- function 'evaluate'. @@ -383,7 +382,7 @@ -> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a #if __GLASGOW_HASKELL__ -catch = GHC.IOBase.catchException +catch = GHC.IO.catchException #elif __HUGS__ catch m h = Hugs.Exception.catchException m h' where h' e = case fromException e of @@ -474,7 +473,7 @@ -- | Like 'finally', but only performs the final action if there was an -- exception raised by the computation. onException :: IO a -> IO b -> IO a -onException io what = io `catch` \e -> do what +onException io what = io `catch` \e -> do _ <- what throw (e :: SomeException) ----------------------------------------------------------------------------- @@ -509,7 +508,7 @@ block (do a <- before r <- unblock (thing a) `onException` after a - after a + _ <- after a return r ) #endif @@ -524,7 +523,7 @@ a `finally` sequel = block (do r <- unblock a `onException` sequel - sequel + _ <- sequel return r ) @@ -691,8 +690,6 @@ ----- -instance Exception Dynamic - #endif /* __GLASGOW_HASKELL__ || __HUGS__ */ #ifdef __GLASGOW_HASKELL__ @@ -700,8 +697,9 @@ nonExhaustiveGuardsError, patError, noMethodBindingError :: Addr# -> a -- All take a UTF8-encoded C string -recSelError s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately -runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately +recSelError s = throw (RecSelError ("No match in record selector " + ++ unpackCStringUtf8# s)) -- No location info unfortunately +runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) diff --git a/lib/base/src/Control/Monad.hs b/lib/base/src/Control/Monad.hs --- a/lib/base/src/Control/Monad.hs +++ b/lib/base/src/Control/Monad.hs @@ -40,6 +40,7 @@ , (>=>) -- :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c) , (<=<) -- :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c) , forever -- :: (Monad m) => m a -> m b + , void -- ** Generalisations of list functions @@ -189,6 +190,10 @@ -- | @'forever' act@ repeats the action infinitely. forever :: (Monad m) => m a -> m b forever a = a >> forever a + +-- | @'void' value@ discards or ignores the result of evaluation, such as the return value of an 'IO' action. +void :: Functor f => f a -> f () +void = fmap (const ()) -- ----------------------------------------------------------------------------- -- Other monad functions diff --git a/lib/base/src/Control/Monad/Fix.hs b/lib/base/src/Control/Monad/Fix.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Monad/Fix.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Fix +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Monadic fixpoints. +-- +-- For a detailed discussion, see Levent Erkok's thesis, +-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002. +-- +----------------------------------------------------------------------------- + +module Control.Monad.Fix ( + MonadFix( + mfix -- :: (a -> m a) -> m a + ), + fix -- :: (a -> a) -> a + ) where + +import Prelude +import System.IO +import Control.Monad.Instances () +import Data.Function (fix) +#ifdef __HUGS__ +import Hugs.Prelude (MonadFix(mfix)) +#endif +#if defined(__GLASGOW_HASKELL__) +import GHC.ST +#endif + +#ifndef __HUGS__ +-- | Monads having fixed points with a \'knot-tying\' semantics. +-- Instances of 'MonadFix' should satisfy the following laws: +-- +-- [/purity/] +-- @'mfix' ('return' . h) = 'return' ('fix' h)@ +-- +-- [/left shrinking/ (or /tightening/)] +-- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@ +-- +-- [/sliding/] +-- @'mfix' ('Control.Monad.liftM' h . f) = 'Control.Monad.liftM' h ('mfix' (f . h))@, +-- for strict @h@. +-- +-- [/nesting/] +-- @'mfix' (\\x -> 'mfix' (\\y -> f x y)) = 'mfix' (\\x -> f x x)@ +-- +-- This class is used in the translation of the recursive @do@ notation +-- supported by GHC and Hugs. +class (Monad m) => MonadFix m where + -- | The fixed point of a monadic computation. + -- @'mfix' f@ executes the action @f@ only once, with the eventual + -- output fed back as the input. Hence @f@ should not be strict, + -- for then @'mfix' f@ would diverge. + mfix :: (a -> m a) -> m a +#endif /* !__HUGS__ */ + +-- Instances of MonadFix for Prelude monads + +-- Maybe: +instance MonadFix Maybe where + mfix f = let a = f (unJust a) in a + where unJust (Just x) = x + unJust Nothing = error "mfix Maybe: Nothing" + +-- List: +instance MonadFix [] where + mfix f = case fix (f . head) of + [] -> [] + (x:_) -> x : mfix (tail . f) + +-- IO: +instance MonadFix IO where + mfix = fixIO + +instance MonadFix ((->) r) where + mfix f = \ r -> let a = f a r in a + +#if defined(__GLASGOW_HASKELL__) +instance MonadFix (ST s) where + mfix = fixST +#endif + diff --git a/lib/base/src/Control/Monad/Instances.hs b/lib/base/src/Control/Monad/Instances.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Monad/Instances.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_NHC98 --prelude #-} +-- This module deliberately declares orphan instances: +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Instances +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 'Functor' and 'Monad' instances for @(->) r@ and +-- 'Functor' instances for @(,) a@ and @'Either' a@. + +module Control.Monad.Instances (Functor(..),Monad(..)) where + +import Prelude + +instance Functor ((->) r) where + fmap = (.) + +instance Monad ((->) r) where + return = const + f >>= k = \ r -> k (f r) r + +instance Functor ((,) a) where + fmap f (x,y) = (x, f y) + +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) diff --git a/lib/base/src/Control/Monad/ST.hs b/lib/base/src/Control/Monad/ST.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Monad/ST.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST + ( + -- * The 'ST' Monad + ST, -- abstract, instance of Functor, Monad, Typeable. + runST, -- :: (forall s. ST s a) -> a + fixST, -- :: (a -> ST s a) -> ST s a + + -- * Converting 'ST' to 'IO' + RealWorld, -- abstract + stToIO, -- :: ST RealWorld a -> IO a + + -- * Unsafe operations + unsafeInterleaveST, -- :: ST s a -> ST s a + unsafeIOToST, -- :: IO a -> ST s a + unsafeSTToIO -- :: ST s a -> IO a + ) where + +#if defined(__GLASGOW_HASKELL__) +import Control.Monad.Fix () +#else +import Control.Monad.Fix +#endif + +#include "Typeable.h" + +#if defined(__GLASGOW_HASKELL__) +import GHC.ST ( ST, runST, fixST, unsafeInterleaveST ) +import GHC.Base ( RealWorld ) +import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) +#elif defined(__HUGS__) +import Data.Typeable +import Hugs.ST +import qualified Hugs.LazyST as LazyST +#endif + +#if defined(__HUGS__) +INSTANCE_TYPEABLE2(ST,sTTc,"ST") +INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld") + +fixST :: (a -> ST s a) -> ST s a +fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f)) + +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST = + LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST +#endif + +#if !defined(__GLASGOW_HASKELL__) +instance MonadFix (ST s) where + mfix = fixST +#endif + diff --git a/lib/base/src/Control/Monad/ST/Lazy.hs b/lib/base/src/Control/Monad/ST/Lazy.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Monad/ST/Lazy.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Lazy +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module presents an identical interface to "Control.Monad.ST", +-- except that the monad delays evaluation of state operations until +-- a value depending on them is required. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Lazy ( + -- * The 'ST' monad + ST, + runST, + fixST, + + -- * Converting between strict and lazy 'ST' + strictToLazyST, lazyToStrictST, + + -- * Converting 'ST' To 'IO' + RealWorld, + stToIO, + + -- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST + ) where + +import Prelude + +import Control.Monad.Fix + +import qualified Control.Monad.ST as ST + +#ifdef __GLASGOW_HASKELL__ +import qualified GHC.ST +import GHC.Base +#endif + +#ifdef __HUGS__ +import Hugs.LazyST +#endif + +#ifdef __GLASGOW_HASKELL__ +-- | The lazy state-transformer monad. +-- A computation of type @'ST' s a@ transforms an internal state indexed +-- by @s@, and returns a value of type @a@. +-- The @s@ parameter is either +-- +-- * an unstantiated type variable (inside invocations of 'runST'), or +-- +-- * 'RealWorld' (inside invocations of 'stToIO'). +-- +-- It serves to keep the internal states of different invocations of +-- 'runST' separate from each other and from invocations of 'stToIO'. +-- +-- The '>>=' and '>>' operations are not strict in the state. For example, +-- +-- @'runST' (writeSTRef _|_ v >>= readSTRef _|_ >> return 2) = 2@ +newtype ST s a = ST (State s -> (a, State s)) +data State s = S# (State# s) + +instance Functor (ST s) where + fmap f m = ST $ \ s -> + let + ST m_a = m + (r,new_s) = m_a s + in + (f r,new_s) + +instance Monad (ST s) where + + return a = ST $ \ s -> (a,s) + m >> k = m >>= \ _ -> k + fail s = error s + + (ST m) >>= k + = ST $ \ s -> + let + (r,new_s) = m s + ST k_a = k r + in + k_a new_s + +{-# NOINLINE runST #-} +-- | Return the value computed by a state transformer computation. +-- The @forall@ ensures that the internal state used by the 'ST' +-- computation is inaccessible to the rest of the program. +runST :: (forall s. ST s a) -> a +runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r + +-- | Allow the result of a state transformer computation to be used (lazily) +-- inside the computation. +-- Note that if @f@ is strict, @'fixST' f = _|_@. +fixST :: (a -> ST s a) -> ST s a +fixST m = ST (\ s -> + let + ST m_r = m r + (r,s') = m_r s + in + (r,s')) +#endif + +instance MonadFix (ST s) where + mfix = fixST + +-- --------------------------------------------------------------------------- +-- Strict <--> Lazy + +#ifdef __GLASGOW_HASKELL__ +{-| +Convert a strict 'ST' computation into a lazy one. The strict state +thread passed to 'strictToLazyST' is not performed until the result of +the lazy state thread it returns is demanded. +-} +strictToLazyST :: ST.ST s a -> ST s a +strictToLazyST m = ST $ \s -> + let + pr = case s of { S# s# -> GHC.ST.liftST m s# } + r = case pr of { GHC.ST.STret _ v -> v } + s' = case pr of { GHC.ST.STret s2# _ -> S# s2# } + in + (r, s') + +{-| +Convert a lazy 'ST' computation into a strict one. +-} +lazyToStrictST :: ST s a -> ST.ST s a +lazyToStrictST (ST m) = GHC.ST.ST $ \s -> + case (m (S# s)) of (a, S# s') -> (# s', a #) + +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST +#endif + +unsafeIOToST :: IO a -> ST s a +unsafeIOToST = strictToLazyST . ST.unsafeIOToST + +-- | A monad transformer embedding lazy state transformers in the 'IO' +-- monad. The 'RealWorld' parameter indicates that the internal state +-- used by the 'ST' computation is a special one supplied by the 'IO' +-- monad, and thus distinct from those used by invocations of 'runST'. +stToIO :: ST RealWorld a -> IO a +stToIO = ST.stToIO . lazyToStrictST diff --git a/lib/base/src/Control/Monad/ST/Strict.hs b/lib/base/src/Control/Monad/ST/Strict.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/Monad/ST/Strict.hs @@ -0,0 +1,19 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Strict +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- The strict ST monad (re-export of "Control.Monad.ST") +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Strict ( + module Control.Monad.ST + ) where + +import Control.Monad.ST diff --git a/lib/base/src/Control/OldException.hs b/lib/base/src/Control/OldException.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Control/OldException.hs @@ -0,0 +1,804 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +#include "Typeable.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.OldException +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (extended exceptions) +-- +-- This module provides support for raising and catching both built-in +-- and user-defined exceptions. +-- +-- In addition to exceptions thrown by 'IO' operations, exceptions may +-- be thrown by pure code (imprecise exceptions) or by external events +-- (asynchronous exceptions), but may only be caught in the 'IO' monad. +-- For more details, see: +-- +-- * /A semantics for imprecise exceptions/, by Simon Peyton Jones, +-- Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson, +-- in /PLDI'99/. +-- +-- * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton +-- Jones, Andy Moran and John Reppy, in /PLDI'01/. +-- +----------------------------------------------------------------------------- + +module Control.OldException {-# DEPRECATED "Future versions of base will not support the old exceptions style. Please switch to extensible exceptions." #-} ( + + -- * The Exception type + Exception(..), -- instance Eq, Ord, Show, Typeable + New.IOException, -- instance Eq, Ord, Show, Typeable + New.ArithException(..), -- instance Eq, Ord, Show, Typeable + New.ArrayException(..), -- instance Eq, Ord, Show, Typeable + New.AsyncException(..), -- instance Eq, Ord, Show, Typeable + + -- * Throwing exceptions + throwIO, -- :: Exception -> IO a + throw, -- :: Exception -> a + ioError, -- :: IOError -> IO a +#ifdef __GLASGOW_HASKELL__ + -- XXX Need to restrict the type of this: + New.throwTo, -- :: ThreadId -> Exception -> a +#endif + + -- * Catching Exceptions + + -- |There are several functions for catching and examining + -- exceptions; all of them may only be used from within the + -- 'IO' monad. + + -- ** The @catch@ functions + catch, -- :: IO a -> (Exception -> IO a) -> IO a + catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a + + -- ** The @handle@ functions + handle, -- :: (Exception -> IO a) -> IO a -> IO a + handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a + + -- ** The @try@ functions + try, -- :: IO a -> IO (Either Exception a) + tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a) + + -- ** The @evaluate@ function + evaluate, -- :: a -> IO a + + -- ** The @mapException@ function + mapException, -- :: (Exception -> Exception) -> a -> a + + -- ** Exception predicates + + -- $preds + + ioErrors, -- :: Exception -> Maybe IOError + arithExceptions, -- :: Exception -> Maybe ArithException + errorCalls, -- :: Exception -> Maybe String + dynExceptions, -- :: Exception -> Maybe Dynamic + assertions, -- :: Exception -> Maybe String + asyncExceptions, -- :: Exception -> Maybe AsyncException + userErrors, -- :: Exception -> Maybe String + + -- * Dynamic exceptions + + -- $dynamic + throwDyn, -- :: Typeable ex => ex -> b +#ifdef __GLASGOW_HASKELL__ + throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b +#endif + catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a + + -- * Asynchronous Exceptions + + -- $async + + -- ** Asynchronous exception control + + -- |The following two functions allow a thread to control delivery of + -- asynchronous exceptions during a critical region. + + block, -- :: IO a -> IO a + unblock, -- :: IO a -> IO a + + -- *** Applying @block@ to an exception handler + + -- $block_handler + + -- *** Interruptible operations + + -- $interruptible + + -- * Assertions + + assert, -- :: Bool -> a -> a + + -- * Utilities + + bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO () + bracket_, -- :: IO a -> IO b -> IO c -> IO () + bracketOnError, + + finally, -- :: IO a -> IO b -> IO a + +#ifdef __GLASGOW_HASKELL__ + setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO () + getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Num +import GHC.Show +-- import GHC.IO ( IO ) +import GHC.IO.Handle.FD ( stdout ) +import qualified GHC.IO as New +import qualified GHC.IO.Exception as New +import GHC.Conc hiding (setUncaughtExceptionHandler, + getUncaughtExceptionHandler) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Foreign.C.String ( CString, withCString ) +import GHC.IO.Handle ( hFlush ) +#endif + +#ifdef __HUGS__ +import Prelude hiding (catch) +import Hugs.Prelude as New (ExitCode(..)) +#endif + +import qualified Control.Exception as New +import Control.Exception ( toException, fromException, throw, block, unblock, evaluate, throwIO ) +import System.IO.Error hiding ( catch, try ) +import System.IO.Unsafe (unsafePerformIO) +import Data.Dynamic +import Data.Either +import Data.Maybe + +#ifdef __NHC__ +import System.IO.Error (catch, ioError) +import IO (bracket) +import DIOError -- defn of IOError type + +-- minimum needed for nhc98 to pretend it has Exceptions +type Exception = IOError +type IOException = IOError +data ArithException +data ArrayException +data AsyncException + +throwIO :: Exception -> IO a +throwIO = ioError +throw :: Exception -> a +throw = unsafePerformIO . throwIO + +evaluate :: a -> IO a +evaluate x = x `seq` return x + +ioErrors :: Exception -> Maybe IOError +ioErrors e = Just e +arithExceptions :: Exception -> Maybe ArithException +arithExceptions = const Nothing +errorCalls :: Exception -> Maybe String +errorCalls = const Nothing +dynExceptions :: Exception -> Maybe Dynamic +dynExceptions = const Nothing +assertions :: Exception -> Maybe String +assertions = const Nothing +asyncExceptions :: Exception -> Maybe AsyncException +asyncExceptions = const Nothing +userErrors :: Exception -> Maybe String +userErrors (UserError _ s) = Just s +userErrors _ = Nothing + +block :: IO a -> IO a +block = id +unblock :: IO a -> IO a +unblock = id + +assert :: Bool -> a -> a +assert True x = x +assert False _ = throw (UserError "" "Assertion failed") +#endif + +----------------------------------------------------------------------------- +-- Catching exceptions + +-- |This is the simplest of the exception-catching functions. It +-- takes a single argument, runs it, and if an exception is raised +-- the \"handler\" is executed, with the value of the exception passed as an +-- argument. Otherwise, the result is returned as normal. For example: +-- +-- > catch (openFile f ReadMode) +-- > (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e)) +-- +-- For catching exceptions in pure (non-'IO') expressions, see the +-- function 'evaluate'. +-- +-- Note that due to Haskell\'s unspecified evaluation order, an +-- expression may return one of several possible exceptions: consider +-- the expression @error \"urk\" + 1 \`div\` 0@. Does +-- 'catch' execute the handler passing +-- @ErrorCall \"urk\"@, or @ArithError DivideByZero@? +-- +-- The answer is \"either\": 'catch' makes a +-- non-deterministic choice about which exception to catch. If you +-- call it again, you might get a different exception back. This is +-- ok, because 'catch' is an 'IO' computation. +-- +-- Note that 'catch' catches all types of exceptions, and is generally +-- used for \"cleaning up\" before passing on the exception using +-- 'throwIO'. It is not good practice to discard the exception and +-- continue, without first checking the type of the exception (it +-- might be a 'ThreadKilled', for example). In this case it is usually better +-- to use 'catchJust' and select the kinds of exceptions to catch. +-- +-- Also note that the "Prelude" also exports a function called +-- 'Prelude.catch' with a similar type to 'Control.OldException.catch', +-- except that the "Prelude" version only catches the IO and user +-- families of exceptions (as required by Haskell 98). +-- +-- We recommend either hiding the "Prelude" version of 'Prelude.catch' +-- when importing "Control.OldException": +-- +-- > import Prelude hiding (catch) +-- +-- or importing "Control.OldException" qualified, to avoid name-clashes: +-- +-- > import qualified Control.OldException as C +-- +-- and then using @C.catch@ +-- + +catch :: IO a -- ^ The computation to run + -> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised + -> IO a +-- note: bundling the exceptions is done in the New.Exception +-- instance of Exception; see below. +catch = New.catch + +-- | The function 'catchJust' is like 'catch', but it takes an extra +-- argument which is an /exception predicate/, a function which +-- selects which type of exceptions we\'re interested in. There are +-- some predefined exception predicates for useful subsets of +-- exceptions: 'ioErrors', 'arithExceptions', and so on. For example, +-- to catch just calls to the 'error' function, we could use +-- +-- > result <- catchJust errorCalls thing_to_try handler +-- +-- Any other exceptions which are not matched by the predicate +-- are re-raised, and may be caught by an enclosing +-- 'catch' or 'catchJust'. +catchJust + :: (Exception -> Maybe b) -- ^ Predicate to select exceptions + -> IO a -- ^ Computation to run + -> (b -> IO a) -- ^ Handler + -> IO a +catchJust p a handler = catch a handler' + where handler' e = case p e of + Nothing -> throw e + Just b -> handler b + +-- | A version of 'catch' with the arguments swapped around; useful in +-- situations where the code for the handler is shorter. For example: +-- +-- > do handle (\e -> exitWith (ExitFailure 1)) $ +-- > ... +handle :: (Exception -> IO a) -> IO a -> IO a +handle = flip catch + +-- | A version of 'catchJust' with the arguments swapped around (see +-- 'handle'). +handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a +handleJust p = flip (catchJust p) + +----------------------------------------------------------------------------- +-- 'mapException' + +-- | This function maps one exception into another as proposed in the +-- paper \"A semantics for imprecise exceptions\". + +-- Notice that the usage of 'unsafePerformIO' is safe here. + +mapException :: (Exception -> Exception) -> a -> a +mapException f v = unsafePerformIO (catch (evaluate v) + (\x -> throw (f x))) + +----------------------------------------------------------------------------- +-- 'try' and variations. + +-- | Similar to 'catch', but returns an 'Either' result which is +-- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an +-- exception was raised and its value is @e@. +-- +-- > try a = catch (Right `liftM` a) (return . Left) +-- +-- Note: as with 'catch', it is only polite to use this variant if you intend +-- to re-throw the exception after performing whatever cleanup is needed. +-- Otherwise, 'tryJust' is generally considered to be better. +-- +-- Also note that "System.IO.Error" also exports a function called +-- 'System.IO.Error.try' with a similar type to 'Control.OldException.try', +-- except that it catches only the IO and user families of exceptions +-- (as required by the Haskell 98 @IO@ module). + +try :: IO a -> IO (Either Exception a) +try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) + +-- | A variant of 'try' that takes an exception predicate to select +-- which exceptions are caught (c.f. 'catchJust'). If the exception +-- does not match the predicate, it is re-thrown. +tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a) +tryJust p a = do + r <- try a + case r of + Right v -> return (Right v) + Left e -> case p e of + Nothing -> throw e + Just b -> return (Left b) + +----------------------------------------------------------------------------- +-- Dynamic exceptions + +-- $dynamic +-- #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an +-- interface for throwing and catching exceptions of type 'Dynamic' +-- (see "Data.Dynamic") which allows exception values of any type in +-- the 'Typeable' class to be thrown and caught. + +-- | Raise any value as an exception, provided it is in the +-- 'Typeable' class. +throwDyn :: Typeable exception => exception -> b +#ifdef __NHC__ +throwDyn exception = throw (UserError "" "dynamic exception") +#else +throwDyn exception = throw (DynException (toDyn exception)) +#endif + +#ifdef __GLASGOW_HASKELL__ +-- | A variant of 'throwDyn' that throws the dynamic exception to an +-- arbitrary thread (GHC only: c.f. 'throwTo'). +throwDynTo :: Typeable exception => ThreadId -> exception -> IO () +throwDynTo t exception = New.throwTo t (DynException (toDyn exception)) +#endif /* __GLASGOW_HASKELL__ */ + +-- | Catch dynamic exceptions of the required type. All other +-- exceptions are re-thrown, including dynamic exceptions of the wrong +-- type. +-- +-- When using dynamic exceptions it is advisable to define a new +-- datatype to use for your exception type, to avoid possible clashes +-- with dynamic exceptions used in other libraries. +-- +catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a +#ifdef __NHC__ +catchDyn m k = m -- can't catch dyn exceptions in nhc98 +#else +catchDyn m k = New.catch m handler + where handler ex = case ex of + (DynException dyn) -> + case fromDynamic dyn of + Just exception -> k exception + Nothing -> throw ex + _ -> throw ex +#endif + +----------------------------------------------------------------------------- +-- Exception Predicates + +-- $preds +-- These pre-defined predicates may be used as the first argument to +-- 'catchJust', 'tryJust', or 'handleJust' to select certain common +-- classes of exceptions. +#ifndef __NHC__ +ioErrors :: Exception -> Maybe IOError +arithExceptions :: Exception -> Maybe New.ArithException +errorCalls :: Exception -> Maybe String +assertions :: Exception -> Maybe String +dynExceptions :: Exception -> Maybe Dynamic +asyncExceptions :: Exception -> Maybe New.AsyncException +userErrors :: Exception -> Maybe String + +ioErrors (IOException e) = Just e +ioErrors _ = Nothing + +arithExceptions (ArithException e) = Just e +arithExceptions _ = Nothing + +errorCalls (ErrorCall e) = Just e +errorCalls _ = Nothing + +assertions (AssertionFailed e) = Just e +assertions _ = Nothing + +dynExceptions (DynException e) = Just e +dynExceptions _ = Nothing + +asyncExceptions (AsyncException e) = Just e +asyncExceptions _ = Nothing + +userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e) +userErrors _ = Nothing +#endif +----------------------------------------------------------------------------- +-- Some Useful Functions + +-- | When you want to acquire a resource, do some work with it, and +-- then release the resource, it is a good idea to use 'bracket', +-- because 'bracket' will install the necessary exception handler to +-- release the resource in the event that an exception is raised +-- during the computation. If an exception is raised, then 'bracket' will +-- re-raise the exception (after performing the release). +-- +-- A common example is opening a file: +-- +-- > bracket +-- > (openFile "filename" ReadMode) +-- > (hClose) +-- > (\handle -> do { ... }) +-- +-- The arguments to 'bracket' are in this order so that we can partially apply +-- it, e.g.: +-- +-- > withFile name mode = bracket (openFile name mode) hClose +-- +#ifndef __NHC__ +bracket + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracket before after thing = + block (do + a <- before + r <- catch + (unblock (thing a)) + (\e -> do { _ <- after a; throw e }) + _ <- after a + return r + ) +#endif + +-- | A specialised variant of 'bracket' with just a computation to run +-- afterward. +-- +finally :: IO a -- ^ computation to run first + -> IO b -- ^ computation to run afterward (even if an exception + -- was raised) + -> IO a -- returns the value from the first computation +a `finally` sequel = + block (do + r <- catch + (unblock a) + (\e -> do { _ <- sequel; throw e }) + _ <- sequel + return r + ) + +-- | A variant of 'bracket' where the return value from the first computation +-- is not required. +bracket_ :: IO a -> IO b -> IO c -> IO c +bracket_ before after thing = bracket before (const after) (const thing) + +-- | Like bracket, but only performs the final action if there was an +-- exception raised by the in-between computation. +bracketOnError + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracketOnError before after thing = + block (do + a <- before + catch + (unblock (thing a)) + (\e -> do { _ <- after a; throw e }) + ) + +-- ----------------------------------------------------------------------------- +-- Asynchronous exceptions + +{- $async + + #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to +external influences, and can be raised at any point during execution. +'StackOverflow' and 'HeapOverflow' are two examples of +system-generated asynchronous exceptions. + +The primary source of asynchronous exceptions, however, is +'throwTo': + +> throwTo :: ThreadId -> Exception -> IO () + +'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one +running thread to raise an arbitrary exception in another thread. The +exception is therefore asynchronous with respect to the target thread, +which could be doing anything at the time it receives the exception. +Great care should be taken with asynchronous exceptions; it is all too +easy to introduce race conditions by the over zealous use of +'throwTo'. +-} + +{- $block_handler +There\'s an implied 'block' around every exception handler in a call +to one of the 'catch' family of functions. This is because that is +what you want most of the time - it eliminates a common race condition +in starting an exception handler, because there may be no exception +handler on the stack to handle another exception if one arrives +immediately. If asynchronous exceptions are blocked on entering the +handler, though, we have time to install a new exception handler +before being interrupted. If this weren\'t the default, one would have +to write something like + +> block ( +> catch (unblock (...)) +> (\e -> handler) +> ) + +If you need to unblock asynchronous exceptions again in the exception +handler, just use 'unblock' as normal. + +Note that 'try' and friends /do not/ have a similar default, because +there is no exception handler in this case. If you want to use 'try' +in an asynchronous-exception-safe way, you will need to use +'block'. +-} + +{- $interruptible + +Some operations are /interruptible/, which means that they can receive +asynchronous exceptions even in the scope of a 'block'. Any function +which may itself block is defined as interruptible; this includes +'Control.Concurrent.MVar.takeMVar' +(but not 'Control.Concurrent.MVar.tryTakeMVar'), +and most operations which perform +some I\/O with the outside world. The reason for having +interruptible operations is so that we can write things like + +> block ( +> a <- takeMVar m +> catch (unblock (...)) +> (\e -> ...) +> ) + +if the 'Control.Concurrent.MVar.takeMVar' was not interruptible, +then this particular +combination could lead to deadlock, because the thread itself would be +blocked in a state where it can\'t receive any asynchronous exceptions. +With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be +safe in the knowledge that the thread can receive exceptions right up +until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds. +Similar arguments apply for other interruptible operations like +'System.IO.openFile'. +-} + +#if !(__GLASGOW_HASKELL__ || __NHC__) +assert :: Bool -> a -> a +assert True x = x +assert False _ = throw (AssertionFailed "") +#endif + + +#ifdef __GLASGOW_HASKELL__ +{-# NOINLINE uncaughtExceptionHandler #-} +uncaughtExceptionHandler :: IORef (Exception -> IO ()) +uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) + where + defaultHandler :: Exception -> IO () + defaultHandler ex = do + (hFlush stdout) `New.catchAny` (\ _ -> return ()) + let msg = case ex of + Deadlock -> "no threads to run: infinite loop or deadlock?" + ErrorCall s -> s + other -> showsPrec 0 other "" + withCString "%s" $ \cfmt -> + withCString msg $ \cmsg -> + errorBelch cfmt cmsg + +-- don't use errorBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h errorBelch2" + errorBelch :: CString -> CString -> IO () + +setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO () +setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler + +getUncaughtExceptionHandler :: IO (Exception -> IO ()) +getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler +#endif + +-- ------------------------------------------------------------------------ +-- Exception datatype and operations + +-- |The type of exceptions. Every kind of system-generated exception +-- has a constructor in the 'Exception' type, and values of other +-- types may be injected into 'Exception' by coercing them to +-- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions: +-- "Control.OldException\#DynamicExceptions"). +data Exception + = ArithException New.ArithException + -- ^Exceptions raised by arithmetic + -- operations. (NOTE: GHC currently does not throw + -- 'ArithException's except for 'DivideByZero'). + | ArrayException New.ArrayException + -- ^Exceptions raised by array-related + -- operations. (NOTE: GHC currently does not throw + -- 'ArrayException's). + | AssertionFailed String + -- ^This exception is thrown by the + -- 'assert' operation when the condition + -- fails. The 'String' argument contains the + -- location of the assertion in the source program. + | AsyncException New.AsyncException + -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.OldException\#AsynchronousExceptions"). + | BlockedOnDeadMVar + -- ^The current thread was executing a call to + -- 'Control.Concurrent.MVar.takeMVar' that could never return, + -- because there are no other references to this 'MVar'. + | BlockedIndefinitely + -- ^The current thread was waiting to retry an atomic memory transaction + -- that could never become possible to complete because there are no other + -- threads referring to any of the TVars involved. + | NestedAtomically + -- ^The runtime detected an attempt to nest one STM transaction + -- inside another one, presumably due to the use of + -- 'unsafePeformIO' with 'atomically'. + | Deadlock + -- ^There are no runnable threads, so the program is + -- deadlocked. The 'Deadlock' exception is + -- raised in the main thread only (see also: "Control.Concurrent"). + | DynException Dynamic + -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.OldException\#DynamicExceptions"). + | ErrorCall String + -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String' + -- argument of 'ErrorCall' is the string passed to 'error' when it was + -- called. + | ExitException New.ExitCode + -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and + -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed + -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the + -- main thread will cause the program to be terminated with the given + -- exit code. + | IOException New.IOException + -- ^These are the standard IO exceptions generated by + -- Haskell\'s @IO@ operations. See also "System.IO.Error". + | NoMethodError String + -- ^An attempt was made to invoke a class method which has + -- no definition in this instance, and there was no default + -- definition given in the class declaration. GHC issues a + -- warning when you compile an instance which has missing + -- methods. + | NonTermination + -- ^The current thread is stuck in an infinite loop. This + -- exception may or may not be thrown when the program is + -- non-terminating. + | PatternMatchFail String + -- ^A pattern matching failure. The 'String' argument should contain a + -- descriptive message including the function name, source file + -- and line number. + | RecConError String + -- ^An attempt was made to evaluate a field of a record + -- for which no value was given at construction time. The + -- 'String' argument gives the location of the + -- record construction in the source program. + | RecSelError String + -- ^A field selection was attempted on a constructor that + -- doesn\'t have the requested field. This can happen with + -- multi-constructor records when one or more fields are + -- missing from some of the constructors. The + -- 'String' argument gives the location of the + -- record selection in the source program. + | RecUpdError String + -- ^An attempt was made to update a field in a record, + -- where the record doesn\'t have the requested field. This can + -- only occur with multi-constructor records, when one or more + -- fields are missing from some of the constructors. The + -- 'String' argument gives the location of the + -- record update in the source program. +INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception") + +-- helper type for simplifying the type casting logic below +data Caster = forall e . New.Exception e => Caster (e -> Exception) + +instance New.Exception Exception where + -- We need to collect all the sorts of exceptions that used to be + -- bundled up into the Exception type, and rebundle them for + -- legacy handlers. + fromException exc0 = foldr tryCast Nothing casters where + tryCast (Caster f) e = case fromException exc0 of + Just exc -> Just (f exc) + _ -> e + casters = + [Caster (\exc -> ArithException exc), + Caster (\exc -> ArrayException exc), + Caster (\(New.AssertionFailed err) -> AssertionFailed err), + Caster (\exc -> AsyncException exc), + Caster (\New.BlockedIndefinitelyOnMVar -> BlockedOnDeadMVar), + Caster (\New.BlockedIndefinitelyOnSTM -> BlockedIndefinitely), + Caster (\New.NestedAtomically -> NestedAtomically), + Caster (\New.Deadlock -> Deadlock), + Caster (\exc -> DynException exc), + Caster (\(New.ErrorCall err) -> ErrorCall err), + Caster (\exc -> ExitException exc), + Caster (\exc -> IOException exc), + Caster (\(New.NoMethodError err) -> NoMethodError err), + Caster (\New.NonTermination -> NonTermination), + Caster (\(New.PatternMatchFail err) -> PatternMatchFail err), + Caster (\(New.RecConError err) -> RecConError err), + Caster (\(New.RecSelError err) -> RecSelError err), + Caster (\(New.RecUpdError err) -> RecUpdError err), + -- Anything else gets taken as a Dynamic exception. It's + -- important that we put all exceptions into the old Exception + -- type somehow, or throwing a new exception wouldn't cause + -- the cleanup code for bracket, finally etc to happen. + Caster (\exc -> DynException (toDyn (exc :: New.SomeException)))] + + -- Unbundle exceptions. + toException (ArithException exc) = toException exc + toException (ArrayException exc) = toException exc + toException (AssertionFailed err) = toException (New.AssertionFailed err) + toException (AsyncException exc) = toException exc + toException BlockedOnDeadMVar = toException New.BlockedIndefinitelyOnMVar + toException BlockedIndefinitely = toException New.BlockedIndefinitelyOnSTM + toException NestedAtomically = toException New.NestedAtomically + toException Deadlock = toException New.Deadlock + -- If a dynamic exception is a SomeException then resurrect it, so + -- that bracket, catch+throw etc rethrow the same exception even + -- when the exception is in the new style. + -- If it's not a SomeException, then just throw the Dynamic. + toException (DynException exc) = case fromDynamic exc of + Just exc' -> exc' + Nothing -> toException exc + toException (ErrorCall err) = toException (New.ErrorCall err) + toException (ExitException exc) = toException exc + toException (IOException exc) = toException exc + toException (NoMethodError err) = toException (New.NoMethodError err) + toException NonTermination = toException New.NonTermination + toException (PatternMatchFail err) = toException (New.PatternMatchFail err) + toException (RecConError err) = toException (New.RecConError err) + toException (RecSelError err) = toException (New.RecSelError err) + toException (RecUpdError err) = toException (New.RecUpdError err) + +instance Show Exception where + showsPrec _ (IOException err) = shows err + showsPrec _ (ArithException err) = shows err + showsPrec _ (ArrayException err) = shows err + showsPrec _ (ErrorCall err) = showString err + showsPrec _ (ExitException err) = showString "exit: " . shows err + showsPrec _ (NoMethodError err) = showString err + showsPrec _ (PatternMatchFail err) = showString err + showsPrec _ (RecSelError err) = showString err + showsPrec _ (RecConError err) = showString err + showsPrec _ (RecUpdError err) = showString err + showsPrec _ (AssertionFailed err) = showString err + showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err) + showsPrec _ (AsyncException e) = shows e + showsPrec p BlockedOnDeadMVar = showsPrec p New.BlockedIndefinitelyOnMVar + showsPrec p BlockedIndefinitely = showsPrec p New.BlockedIndefinitelyOnSTM + showsPrec p NestedAtomically = showsPrec p New.NestedAtomically + showsPrec p NonTermination = showsPrec p New.NonTermination + showsPrec p Deadlock = showsPrec p New.Deadlock + +instance Eq Exception where + IOException e1 == IOException e2 = e1 == e2 + ArithException e1 == ArithException e2 = e1 == e2 + ArrayException e1 == ArrayException e2 = e1 == e2 + ErrorCall e1 == ErrorCall e2 = e1 == e2 + ExitException e1 == ExitException e2 = e1 == e2 + NoMethodError e1 == NoMethodError e2 = e1 == e2 + PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2 + RecSelError e1 == RecSelError e2 = e1 == e2 + RecConError e1 == RecConError e2 = e1 == e2 + RecUpdError e1 == RecUpdError e2 = e1 == e2 + AssertionFailed e1 == AssertionFailed e2 = e1 == e2 + DynException _ == DynException _ = False -- incomparable + AsyncException e1 == AsyncException e2 = e1 == e2 + BlockedOnDeadMVar == BlockedOnDeadMVar = True + NonTermination == NonTermination = True + NestedAtomically == NestedAtomically = True + Deadlock == Deadlock = True + _ == _ = False + diff --git a/lib/base/src/Data/Bits.hs b/lib/base/src/Data/Bits.hs --- a/lib/base/src/Data/Bits.hs +++ b/lib/base/src/Data/Bits.hs @@ -42,14 +42,12 @@ -- See library document for details on the semantics of the -- individual operations. -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#) -#define WORD_SIZE_IN_BITS (WORD_SIZE * 8) +#if !defined(__LHC__) && defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +#include "MachDeps.h" #endif #ifdef __GLASGOW_HASKELL__ import GHC.Num -import GHC.Real import GHC.Base #endif @@ -153,6 +151,11 @@ value of the argument is ignored -} isSigned :: a -> Bool + {-# INLINE bit #-} + {-# INLINE setBit #-} + {-# INLINE clearBit #-} + {-# INLINE complementBit #-} + {-# INLINE testBit #-} bit i = 1 `shiftL` i x `setBit` i = x .|. bit i x `clearBit` i = x .&. complement (bit i) @@ -166,6 +169,7 @@ 'shift', depending on which is more convenient for the type in question. -} shiftL :: a -> Int -> a + {-# INLINE shiftL #-} x `shiftL` i = x `shift` i {-| Shift the first argument right by the specified number of bits @@ -178,6 +182,7 @@ 'shift', depending on which is more convenient for the type in question. -} shiftR :: a -> Int -> a + {-# INLINE shiftR #-} x `shiftR` i = x `shift` (-i) {-| Rotate the argument left by the specified number of bits @@ -187,6 +192,7 @@ 'rotate', depending on which is more convenient for the type in question. -} rotateL :: a -> Int -> a + {-# INLINE rotateL #-} x `rotateL` i = x `rotate` i {-| Rotate the argument right by the specified number of bits @@ -196,6 +202,7 @@ 'rotate', depending on which is more convenient for the type in question. -} rotateR :: a -> Int -> a + {-# INLINE rotateR #-} x `rotateR` i = x `rotate` (-i) instance Bits Int where @@ -219,14 +226,11 @@ I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (wsib -# i'#)))) where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) - wsib = WORD_SIZE_IN_BITS_ {- work around preprocessor problem (??) -} + !x'# = int2Word# x# + !i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} bitSize _ = WORD_SIZE_IN_BITS - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) #else /* !__GLASGOW_HASKELL__ */ #ifdef __HUGS__ @@ -275,6 +279,10 @@ (.|.) = orInteger xor = xorInteger complement = complementInteger +-- shift x i@(I# i#) | i >= 0 = shiftLInteger x i# +-- | otherwise = shiftRInteger x (negateInt# i#) +-- Didn't bother to implement shifts for integers. It shouldn't be problematic, I just don't have the time. + shift x i = shift x i #else -- reduce bitwise binary operations to special cases we can handle @@ -291,10 +299,9 @@ -- assuming infinite 2's-complement arithmetic complement a = -1 - a -#endif - shift x i | i >= 0 = x * 2^i | otherwise = x `div` 2^(-i) +#endif rotate x i = shift x i -- since an Integer never wraps around diff --git a/lib/base/src/Data/Bool.hs b/lib/base/src/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Bool.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bool +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The 'Bool' type and related functions. +-- +----------------------------------------------------------------------------- + +module Data.Bool ( + -- * Booleans + Bool(..), + -- ** Operations + (&&), -- :: Bool -> Bool -> Bool + (||), -- :: Bool -> Bool -> Bool + not, -- :: Bool -> Bool + otherwise, -- :: Bool + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#endif + +#ifdef __NHC__ +import Prelude +import Prelude + ( Bool(..) + , (&&) + , (||) + , not + , otherwise + ) +#endif diff --git a/lib/base/src/Data/Char.hs b/lib/base/src/Data/Char.hs --- a/lib/base/src/Data/Char.hs +++ b/lib/base/src/Data/Char.hs @@ -134,9 +134,7 @@ -- | The Unicode general category of the character. generalCategory :: Char -> GeneralCategory -#if defined(__LHC__) -generalCategory c = NotAssigned -#elif defined(__GLASGOW_HASKELL__) || defined(__NHC__) +#if defined(__GLASGOW_HASKELL__) || defined(__NHC__) generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c #endif #ifdef __HUGS__ diff --git a/lib/base/src/Data/Complex.hs b/lib/base/src/Data/Complex.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Complex.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Complex +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Complex numbers. +-- +----------------------------------------------------------------------------- + +module Data.Complex + ( + -- * Rectangular form + Complex((:+)) + + , realPart -- :: (RealFloat a) => Complex a -> a + , imagPart -- :: (RealFloat a) => Complex a -> a + -- * Polar form + , mkPolar -- :: (RealFloat a) => a -> a -> Complex a + , cis -- :: (RealFloat a) => a -> Complex a + , polar -- :: (RealFloat a) => Complex a -> (a,a) + , magnitude -- :: (RealFloat a) => Complex a -> a + , phase -- :: (RealFloat a) => Complex a -> a + -- * Conjugate + , conjugate -- :: (RealFloat a) => Complex a -> Complex a + + -- Complex instances: + -- + -- (RealFloat a) => Eq (Complex a) + -- (RealFloat a) => Read (Complex a) + -- (RealFloat a) => Show (Complex a) + -- (RealFloat a) => Num (Complex a) + -- (RealFloat a) => Fractional (Complex a) + -- (RealFloat a) => Floating (Complex a) + -- + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + + ) where + +import Prelude + +import Data.Typeable +#ifdef __GLASGOW_HASKELL__ +import Data.Data (Data) +#endif + +#ifdef __HUGS__ +import Hugs.Prelude(Num(fromInt), Fractional(fromDouble)) +#endif + +infix 6 :+ + +-- ----------------------------------------------------------------------------- +-- The Complex type + +-- | Complex numbers are an algebraic type. +-- +-- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@, +-- but oriented in the positive real direction, whereas @'signum' z@ +-- has the phase of @z@, but unit magnitude. +data (RealFloat a) => Complex a + = !a :+ !a -- ^ forms a complex number from its real and imaginary + -- rectangular components. +# if __GLASGOW_HASKELL__ + deriving (Eq, Show, Read, Data) +# else + deriving (Eq, Show, Read) +# endif + +-- ----------------------------------------------------------------------------- +-- Functions over Complex + +-- | Extracts the real part of a complex number. +realPart :: (RealFloat a) => Complex a -> a +realPart (x :+ _) = x + +-- | Extracts the imaginary part of a complex number. +imagPart :: (RealFloat a) => Complex a -> a +imagPart (_ :+ y) = y + +-- | The conjugate of a complex number. +{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-} +conjugate :: (RealFloat a) => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +-- | Form a complex number from polar components of magnitude and phase. +{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-} +mkPolar :: (RealFloat a) => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +-- | @'cis' t@ is a complex value with magnitude @1@ +-- and phase @t@ (modulo @2*'pi'@). +{-# SPECIALISE cis :: Double -> Complex Double #-} +cis :: (RealFloat a) => a -> Complex a +cis theta = cos theta :+ sin theta + +-- | The function 'polar' takes a complex number and +-- returns a (magnitude, phase) pair in canonical form: +-- the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@; +-- if the magnitude is zero, then so is the phase. +{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +-- | The nonnegative magnitude of a complex number. +{-# SPECIALISE magnitude :: Complex Double -> Double #-} +magnitude :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y))) + where k = max (exponent x) (exponent y) + mk = - k + sqr z = z * z + +-- | The phase of a complex number, in the range @(-'pi', 'pi']@. +-- If the magnitude is zero, then so is the phase. +{-# SPECIALISE phase :: Complex Double -> Double #-} +phase :: (RealFloat a) => Complex a -> a +phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson +phase (x:+y) = atan2 y x + + +-- ----------------------------------------------------------------------------- +-- Instances of Complex + +#include "Typeable.h" +INSTANCE_TYPEABLE1(Complex,complexTc,"Complex") + +instance (RealFloat a) => Num (Complex a) where + {-# SPECIALISE instance Num (Complex Float) #-} + {-# SPECIALISE instance Num (Complex Double) #-} + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum (0:+0) = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 +#ifdef __HUGS__ + fromInt n = fromInt n :+ 0 +#endif + +instance (RealFloat a) => Fractional (Complex a) where + {-# SPECIALISE instance Fractional (Complex Float) #-} + {-# SPECIALISE instance Fractional (Complex Double) #-} + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 +#ifdef __HUGS__ + fromDouble a = fromDouble a :+ 0 +#endif + +instance (RealFloat a) => Floating (Complex a) where + {-# SPECIALISE instance Floating (Complex Float) #-} + {-# SPECIALISE instance Floating (Complex Double) #-} + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + + sqrt (0:+0) = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) diff --git a/lib/base/src/Data/Data.hs b/lib/base/src/Data/Data.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Data.hs @@ -0,0 +1,1320 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Data +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (local universal quantification) +-- +-- \"Scrap your boilerplate\" --- Generic programming in Haskell. +-- See . This module provides +-- the 'Data' class with its primitives for generic programming, along +-- with instances for many datatypes. It corresponds to a merge between +-- the previous "Data.Generics.Basics" and almost all of +-- "Data.Generics.Instances". The instances that are not present +-- in this module were moved to the @Data.Generics.Instances@ module +-- in the @syb@ package. +-- +-- For more information, please visit the new +-- SYB wiki: . +-- +-- +----------------------------------------------------------------------------- + +module Data.Data ( + + -- * Module Data.Typeable re-exported for convenience + module Data.Typeable, + + -- * The Data class for processing constructor applications + Data( + gfoldl, -- :: ... -> a -> c a + gunfold, -- :: ... -> Constr -> c a + toConstr, -- :: a -> Constr + dataTypeOf, -- :: a -> DataType + dataCast1, -- mediate types and unary type constructors + dataCast2, -- mediate types and binary type constructors + -- Generic maps defined in terms of gfoldl + gmapT, + gmapQ, + gmapQl, + gmapQr, + gmapQi, + gmapM, + gmapMp, + gmapMo + ), + + -- * Datatype representations + DataType, -- abstract, instance of: Show + -- ** Constructors + mkDataType, -- :: String -> [Constr] -> DataType + mkIntType, -- :: String -> DataType + mkFloatType, -- :: String -> DataType + mkStringType, -- :: String -> DataType + mkCharType, -- :: String -> DataType + mkNoRepType, -- :: String -> DataType + mkNorepType, -- :: String -> DataType + -- ** Observers + dataTypeName, -- :: DataType -> String + DataRep(..), -- instance of: Eq, Show + dataTypeRep, -- :: DataType -> DataRep + -- ** Convenience functions + repConstr, -- :: DataType -> ConstrRep -> Constr + isAlgType, -- :: DataType -> Bool + dataTypeConstrs,-- :: DataType -> [Constr] + indexConstr, -- :: DataType -> ConIndex -> Constr + maxConstrIndex, -- :: DataType -> ConIndex + isNorepType, -- :: DataType -> Bool + + -- * Data constructor representations + Constr, -- abstract, instance of: Eq, Show + ConIndex, -- alias for Int, start at 1 + Fixity(..), -- instance of: Eq, Show + -- ** Constructors + mkConstr, -- :: DataType -> String -> Fixity -> Constr + mkIntConstr, -- :: DataType -> Integer -> Constr + mkFloatConstr, -- :: DataType -> Double -> Constr + mkIntegralConstr,-- :: (Integral a) => DataType -> a -> Constr + mkRealConstr, -- :: (Real a) => DataType -> a -> Constr + mkStringConstr, -- :: DataType -> String -> Constr + mkCharConstr, -- :: DataType -> Char -> Constr + -- ** Observers + constrType, -- :: Constr -> DataType + ConstrRep(..), -- instance of: Eq, Show + constrRep, -- :: Constr -> ConstrRep + constrFields, -- :: Constr -> [String] + constrFixity, -- :: Constr -> Fixity + -- ** Convenience function: algebraic data types + constrIndex, -- :: Constr -> ConIndex + -- ** From strings to constructors and vice versa: all data types + showConstr, -- :: Constr -> String + readConstr, -- :: DataType -> String -> Maybe Constr + + -- * Convenience functions: take type constructors apart + tyconUQname, -- :: String -> String + tyconModule, -- :: String -> String + + -- * Generic operations defined in terms of 'gunfold' + fromConstr, -- :: Constr -> a + fromConstrB, -- :: ... -> Constr -> a + fromConstrM -- :: Monad m => ... -> Constr -> m a + + ) where + + +------------------------------------------------------------------------------ + +import Prelude -- necessary to get dependencies right + +import Data.Typeable +import Data.Maybe +import Control.Monad + +-- Imports for the instances +import Data.Int -- So we can give Data instance for Int8, ... +import Data.Word -- So we can give Data instance for Word8, ... +#ifdef __GLASGOW_HASKELL__ +import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio +--import GHC.IOBase -- So we can give Data instance for IO, Handle +import GHC.Ptr -- So we can give Data instance for Ptr +import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr +--import GHC.Stable -- So we can give Data instance for StablePtr +--import GHC.ST -- So we can give Data instance for ST +--import GHC.Conc -- So we can give Data instance for MVar & Co. +import GHC.Arr -- So we can give Data instance for Array +#else +# ifdef __HUGS__ +import Hugs.Prelude( Ratio(..) ) +# endif +import Foreign.Ptr +import Foreign.ForeignPtr +import Data.Array +#endif + +#include "Typeable.h" + + + +------------------------------------------------------------------------------ +-- +-- The Data class +-- +------------------------------------------------------------------------------ + +{- | +The 'Data' class comprehends a fundamental primitive 'gfoldl' for +folding over constructor applications, say terms. This primitive can +be instantiated in several ways to map over the immediate subterms +of a term; see the @gmap@ combinators later in this class. Indeed, a +generic programmer does not necessarily need to use the ingenious gfoldl +primitive but rather the intuitive @gmap@ combinators. The 'gfoldl' +primitive is completed by means to query top-level constructors, to +turn constructor representations into proper terms, and to list all +possible datatype constructors. This completion allows us to serve +generic programming scenarios like read, show, equality, term generation. + +The combinators 'gmapT', 'gmapQ', 'gmapM', etc are all provided with +default definitions in terms of 'gfoldl', leaving open the opportunity +to provide datatype-specific definitions. +(The inclusion of the @gmap@ combinators as members of class 'Data' +allows the programmer or the compiler to derive specialised, and maybe +more efficient code per datatype. /Note/: 'gfoldl' is more higher-order +than the @gmap@ combinators. This is subject to ongoing benchmarking +experiments. It might turn out that the @gmap@ combinators will be +moved out of the class 'Data'.) + +Conceptually, the definition of the @gmap@ combinators in terms of the +primitive 'gfoldl' requires the identification of the 'gfoldl' function +arguments. Technically, we also need to identify the type constructor +@c@ for the construction of the result type from the folded term type. + +In the definition of @gmapQ@/x/ combinators, we use phantom type +constructors for the @c@ in the type of 'gfoldl' because the result type +of a query does not involve the (polymorphic) type of the term argument. +In the definition of 'gmapQl' we simply use the plain constant type +constructor because 'gfoldl' is left-associative anyway and so it is +readily suited to fold a left-associative binary operation over the +immediate subterms. In the definition of gmapQr, extra effort is +needed. We use a higher-order accumulation trick to mediate between +left-associative constructor application vs. right-associative binary +operation (e.g., @(:)@). When the query is meant to compute a value +of type @r@, then the result type withing generic folding is @r -> r@. +So the result of folding is a function to which we finally pass the +right unit. + +With the @-XDeriveDataTypeable@ option, GHC can generate instances of the +'Data' class automatically. For example, given the declaration + +> data T a b = C1 a b | C2 deriving (Typeable, Data) + +GHC will generate an instance that is equivalent to + +> instance (Data a, Data b) => Data (T a b) where +> gfoldl k z (C1 a b) = z C1 `k` a `k` b +> gfoldl k z C2 = z C2 +> +> gunfold k z c = case constrIndex c of +> 1 -> k (k (z C1)) +> 2 -> z C2 +> +> toConstr (C1 _ _) = con_C1 +> toConstr C2 = con_C2 +> +> dataTypeOf _ = ty_T +> +> con_C1 = mkConstr ty_T "C1" [] Prefix +> con_C2 = mkConstr ty_T "C2" [] Prefix +> ty_T = mkDataType "Module.T" [con_C1, con_C2] + +This is suitable for datatypes that are exported transparently. + +-} + +class Typeable a => Data a where + + -- | Left-associative fold operation for constructor applications. + -- + -- The type of 'gfoldl' is a headache, but operationally it is a simple + -- generalisation of a list fold. + -- + -- The default definition for 'gfoldl' is @'const' 'id'@, which is + -- suitable for abstract datatypes with no substructures. + gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) + -- ^ defines how nonempty constructor applications are + -- folded. It takes the folded tail of the constructor + -- application and its head, i.e., an immediate subterm, + -- and combines them in some way. + -> (forall g. g -> c g) + -- ^ defines how the empty constructor application is + -- folded, like the neutral \/ start element for list + -- folding. + -> a + -- ^ structure to be folded. + -> c a + -- ^ result, with a type defined in terms of @a@, but + -- variability is achieved by means of type constructor + -- @c@ for the construction of the actual result type. + + -- See the 'Data' instances in this file for an illustration of 'gfoldl'. + + gfoldl _ z = z + + -- | Unfolding constructor applications + gunfold :: (forall b r. Data b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> Constr + -> c a + + -- | Obtaining the constructor from a given datum. + -- For proper terms, this is meant to be the top-level constructor. + -- Primitive datatypes are here viewed as potentially infinite sets of + -- values (i.e., constructors). + toConstr :: a -> Constr + + + -- | The outer type constructor of the type + dataTypeOf :: a -> DataType + + + +------------------------------------------------------------------------------ +-- +-- Mediate types and type constructors +-- +------------------------------------------------------------------------------ + + -- | Mediate types and unary type constructors. + -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined + -- as 'gcast1'. + -- + -- The default definition is @'const' 'Nothing'@, which is appropriate + -- for non-unary type constructors. + dataCast1 :: Typeable1 t + => (forall d. Data d => c (t d)) + -> Maybe (c a) + dataCast1 _ = Nothing + + -- | Mediate types and binary type constructors. + -- In 'Data' instances of the form @T a b@, 'dataCast2' should be + -- defined as 'gcast2'. + -- + -- The default definition is @'const' 'Nothing'@, which is appropriate + -- for non-binary type constructors. + dataCast2 :: Typeable2 t + => (forall d e. (Data d, Data e) => c (t d e)) + -> Maybe (c a) + dataCast2 _ = Nothing + + + +------------------------------------------------------------------------------ +-- +-- Typical generic maps defined in terms of gfoldl +-- +------------------------------------------------------------------------------ + + + -- | A generic transformation that maps over the immediate subterms + -- + -- The default definition instantiates the type constructor @c@ in the + -- type of 'gfoldl' to an identity datatype constructor, using the + -- isomorphism pair as injection and projection. + gmapT :: (forall b. Data b => b -> b) -> a -> a + + -- Use an identity datatype constructor ID (see below) + -- to instantiate the type constructor c in the type of gfoldl, + -- and perform injections ID and projections unID accordingly. + -- + gmapT f x0 = unID (gfoldl k ID x0) + where + k (ID c) x = ID (c (f x)) + + + -- | A generic query with a left-associative binary operator + gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r + gmapQl o r f = unCONST . gfoldl k z + where + k c x = CONST $ (unCONST c) `o` f x + z _ = CONST r + + -- | A generic query with a right-associative binary operator + gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r + gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0 + where + k (Qr c) x = Qr (\r -> c (f x `o` r)) + + + -- | A generic query that processes the immediate subterms and returns a list + -- of results. The list is given in the same order as originally specified + -- in the declaratoin of the data constructors. + gmapQ :: (forall d. Data d => d -> u) -> a -> [u] + gmapQ f = gmapQr (:) [] f + + + -- | A generic query that processes one child by index (zero-based) + gmapQi :: Int -> (forall d. Data d => d -> u) -> a -> u + gmapQi i f x = case gfoldl k z x of { Qi _ q -> fromJust q } + where + k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q) + z _ = Qi 0 Nothing + + + -- | A generic monadic transformation that maps over the immediate subterms + -- + -- The default definition instantiates the type constructor @c@ in + -- the type of 'gfoldl' to the monad datatype constructor, defining + -- injection and projection using 'return' and '>>='. + gmapM :: Monad m => (forall d. Data d => d -> m d) -> a -> m a + + -- Use immediately the monad datatype constructor + -- to instantiate the type constructor c in the type of gfoldl, + -- so injection and projection is done by return and >>=. + -- + gmapM f = gfoldl k return + where + k c x = do c' <- c + x' <- f x + return (c' x') + + + -- | Transformation of at least one immediate subterm does not fail + gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + +{- + +The type constructor that we use here simply keeps track of the fact +if we already succeeded for an immediate subterm; see Mp below. To +this end, we couple the monadic computation with a Boolean. + +-} + + gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) -> + if b then return x' else mzero + where + z g = Mp (return (g,False)) + k (Mp c) y + = Mp ( c >>= \(h, b) -> + (f y >>= \y' -> return (h y', True)) + `mplus` return (h y, b) + ) + + -- | Transformation of one immediate subterm with success + gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + +{- + +We use the same pairing trick as for gmapMp, +i.e., we use an extra Bool component to keep track of the +fact whether an immediate subterm was processed successfully. +However, we cut of mapping over subterms once a first subterm +was transformed successfully. + +-} + + gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) -> + if b then return x' else mzero + where + z g = Mp (return (g,False)) + k (Mp c) y + = Mp ( c >>= \(h,b) -> if b + then return (h y, b) + else (f y >>= \y' -> return (h y',True)) + `mplus` return (h y, b) + ) + + +-- | The identity type constructor needed for the definition of gmapT +newtype ID x = ID { unID :: x } + + +-- | The constant type constructor needed for the definition of gmapQl +newtype CONST c a = CONST { unCONST :: c } + + +-- | Type constructor for adding counters to queries +data Qi q a = Qi Int (Maybe q) + + +-- | The type constructor used in definition of gmapQr +newtype Qr r a = Qr { unQr :: r -> r } + + +-- | The type constructor used in definition of gmapMp +newtype Mp m x = Mp { unMp :: m (x, Bool) } + + + +------------------------------------------------------------------------------ +-- +-- Generic unfolding +-- +------------------------------------------------------------------------------ + + +-- | Build a term skeleton +fromConstr :: Data a => Constr -> a +fromConstr = fromConstrB (error "Data.Data.fromConstr") + + +-- | Build a term and use a generic function for subterms +fromConstrB :: Data a + => (forall d. Data d => d) + -> Constr + -> a +fromConstrB f = unID . gunfold k z + where + k c = ID (unID c f) + z = ID + + +-- | Monadic variation on 'fromConstrB' +fromConstrM :: (Monad m, Data a) + => (forall d. Data d => m d) + -> Constr + -> m a +fromConstrM f = gunfold k z + where + k c = do { c' <- c; b <- f; return (c' b) } + z = return + + + +------------------------------------------------------------------------------ +-- +-- Datatype and constructor representations +-- +------------------------------------------------------------------------------ + + +-- +-- | Representation of datatypes. +-- A package of constructor representations with names of type and module. +-- +data DataType = DataType + { tycon :: String + , datarep :: DataRep + } + + deriving Show + +-- | Representation of constructors. Note that equality on constructors +-- with different types may not work -- i.e. the constructors for 'False' and +-- 'Nothing' may compare equal. +data Constr = Constr + { conrep :: ConstrRep + , constring :: String + , confields :: [String] -- for AlgRep only + , confixity :: Fixity -- for AlgRep only + , datatype :: DataType + } + +instance Show Constr where + show = constring + + +-- | Equality of constructors +instance Eq Constr where + c == c' = constrRep c == constrRep c' + + +-- | Public representation of datatypes +data DataRep = AlgRep [Constr] + | IntRep + | FloatRep + | CharRep + | NoRep + + deriving (Eq,Show) +-- The list of constructors could be an array, a balanced tree, or others. + + +-- | Public representation of constructors +data ConstrRep = AlgConstr ConIndex + | IntConstr Integer + | FloatConstr Rational + | CharConstr Char + + deriving (Eq,Show) + + +-- | Unique index for datatype constructors, +-- counting from 1 in the order they are given in the program text. +type ConIndex = Int + + +-- | Fixity of constructors +data Fixity = Prefix + | Infix -- Later: add associativity and precedence + + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- +-- Observers for datatype representations +-- +------------------------------------------------------------------------------ + + +-- | Gets the type constructor including the module +dataTypeName :: DataType -> String +dataTypeName = tycon + + + +-- | Gets the public presentation of a datatype +dataTypeRep :: DataType -> DataRep +dataTypeRep = datarep + + +-- | Gets the datatype of a constructor +constrType :: Constr -> DataType +constrType = datatype + + +-- | Gets the public presentation of constructors +constrRep :: Constr -> ConstrRep +constrRep = conrep + + +-- | Look up a constructor by its representation +repConstr :: DataType -> ConstrRep -> Constr +repConstr dt cr = + case (dataTypeRep dt, cr) of + (AlgRep cs, AlgConstr i) -> cs !! (i-1) + (IntRep, IntConstr i) -> mkIntConstr dt i + (FloatRep, FloatConstr f) -> mkRealConstr dt f + (CharRep, CharConstr c) -> mkCharConstr dt c + _ -> error "repConstr" + + + +------------------------------------------------------------------------------ +-- +-- Representations of algebraic data types +-- +------------------------------------------------------------------------------ + + +-- | Constructs an algebraic datatype +mkDataType :: String -> [Constr] -> DataType +mkDataType str cs = DataType + { tycon = str + , datarep = AlgRep cs + } + + +-- | Constructs a constructor +mkConstr :: DataType -> String -> [String] -> Fixity -> Constr +mkConstr dt str fields fix = + Constr + { conrep = AlgConstr idx + , constring = str + , confields = fields + , confixity = fix + , datatype = dt + } + where + idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..], + showConstr c == str ] + + +-- | Gets the constructors of an algebraic datatype +dataTypeConstrs :: DataType -> [Constr] +dataTypeConstrs dt = case datarep dt of + (AlgRep cons) -> cons + _ -> error "dataTypeConstrs" + + +-- | Gets the field labels of a constructor. The list of labels +-- is returned in the same order as they were given in the original +-- constructor declaration. +constrFields :: Constr -> [String] +constrFields = confields + + +-- | Gets the fixity of a constructor +constrFixity :: Constr -> Fixity +constrFixity = confixity + + + +------------------------------------------------------------------------------ +-- +-- From strings to constr's and vice versa: all data types +-- +------------------------------------------------------------------------------ + + +-- | Gets the string for a constructor +showConstr :: Constr -> String +showConstr = constring + + +-- | Lookup a constructor via a string +readConstr :: DataType -> String -> Maybe Constr +readConstr dt str = + case dataTypeRep dt of + AlgRep cons -> idx cons + IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i))) + FloatRep -> mkReadCon ffloat + CharRep -> mkReadCon (\c -> (mkPrimCon dt str (CharConstr c))) + NoRep -> Nothing + where + + -- Read a value and build a constructor + mkReadCon :: Read t => (t -> Constr) -> Maybe Constr + mkReadCon f = case (reads str) of + [(t,"")] -> Just (f t) + _ -> Nothing + + -- Traverse list of algebraic datatype constructors + idx :: [Constr] -> Maybe Constr + idx cons = let fit = filter ((==) str . showConstr) cons + in if fit == [] + then Nothing + else Just (head fit) + + ffloat :: Double -> Constr + ffloat = mkPrimCon dt str . FloatConstr . toRational + +------------------------------------------------------------------------------ +-- +-- Convenience funtions: algebraic data types +-- +------------------------------------------------------------------------------ + + +-- | Test for an algebraic type +isAlgType :: DataType -> Bool +isAlgType dt = case datarep dt of + (AlgRep _) -> True + _ -> False + + +-- | Gets the constructor for an index (algebraic datatypes only) +indexConstr :: DataType -> ConIndex -> Constr +indexConstr dt idx = case datarep dt of + (AlgRep cs) -> cs !! (idx-1) + _ -> error "indexConstr" + + +-- | Gets the index of a constructor (algebraic datatypes only) +constrIndex :: Constr -> ConIndex +constrIndex con = case constrRep con of + (AlgConstr idx) -> idx + _ -> error "constrIndex" + + +-- | Gets the maximum constructor index of an algebraic datatype +maxConstrIndex :: DataType -> ConIndex +maxConstrIndex dt = case dataTypeRep dt of + AlgRep cs -> length cs + _ -> error "maxConstrIndex" + + + +------------------------------------------------------------------------------ +-- +-- Representation of primitive types +-- +------------------------------------------------------------------------------ + + +-- | Constructs the 'Int' type +mkIntType :: String -> DataType +mkIntType = mkPrimType IntRep + + +-- | Constructs the 'Float' type +mkFloatType :: String -> DataType +mkFloatType = mkPrimType FloatRep + + +-- | This function is now deprecated. Please use 'mkCharType' instead. +{-# DEPRECATED mkStringType "Use mkCharType instead" #-} +mkStringType :: String -> DataType +mkStringType = mkCharType + +-- | Constructs the 'Char' type +mkCharType :: String -> DataType +mkCharType = mkPrimType CharRep + + +-- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType' +mkPrimType :: DataRep -> String -> DataType +mkPrimType dr str = DataType + { tycon = str + , datarep = dr + } + + +-- Makes a constructor for primitive types +mkPrimCon :: DataType -> String -> ConstrRep -> Constr +mkPrimCon dt str cr = Constr + { datatype = dt + , conrep = cr + , constring = str + , confields = error "constrFields" + , confixity = error "constrFixity" + } + +-- | This function is now deprecated. Please use 'mkIntegralConstr' instead. +{-# DEPRECATED mkIntConstr "Use mkIntegralConstr instead" #-} +mkIntConstr :: DataType -> Integer -> Constr +mkIntConstr = mkIntegralConstr + +mkIntegralConstr :: (Integral a) => DataType -> a -> Constr +mkIntegralConstr dt i = case datarep dt of + IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger i)) + _ -> error "mkIntegralConstr" + +-- | This function is now deprecated. Please use 'mkRealConstr' instead. +{-# DEPRECATED mkFloatConstr "Use mkRealConstr instead" #-} +mkFloatConstr :: DataType -> Double -> Constr +mkFloatConstr dt = mkRealConstr dt . toRational + +mkRealConstr :: (Real a) => DataType -> a -> Constr +mkRealConstr dt f = case datarep dt of + FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f)) + _ -> error "mkRealConstr" + +-- | This function is now deprecated. Please use 'mkCharConstr' instead. +{-# DEPRECATED mkStringConstr "Use mkCharConstr instead" #-} +mkStringConstr :: DataType -> String -> Constr +mkStringConstr dt str = + case datarep dt of + CharRep -> case str of + [c] -> mkPrimCon dt (show c) (CharConstr c) + _ -> error "mkStringConstr: input String must contain a single character" + _ -> error "mkStringConstr" + +-- | Makes a constructor for 'Char'. +mkCharConstr :: DataType -> Char -> Constr +mkCharConstr dt c = case datarep dt of + CharRep -> mkPrimCon dt (show c) (CharConstr c) + _ -> error "mkCharConstr" + + +------------------------------------------------------------------------------ +-- +-- Non-representations for non-presentable types +-- +------------------------------------------------------------------------------ + + +-- | Deprecated version (misnamed) +{-# DEPRECATED mkNorepType "Use mkNoRepType instead" #-} +mkNorepType :: String -> DataType +mkNorepType str = DataType + { tycon = str + , datarep = NoRep + } + +-- | Constructs a non-representation for a non-presentable type +mkNoRepType :: String -> DataType +mkNoRepType str = DataType + { tycon = str + , datarep = NoRep + } + +-- | Test for a non-representable type +isNorepType :: DataType -> Bool +isNorepType dt = case datarep dt of + NoRep -> True + _ -> False + + + +------------------------------------------------------------------------------ +-- +-- Convenience for qualified type constructors +-- +------------------------------------------------------------------------------ + + +-- | Gets the unqualified type constructor: +-- drop *.*.*... before name +-- +tyconUQname :: String -> String +tyconUQname x = let x' = dropWhile (not . (==) '.') x + in if x' == [] then x else tyconUQname (tail x') + + +-- | Gets the module of a type constructor: +-- take *.*.*... before name +tyconModule :: String -> String +tyconModule x = let (a,b) = break ((==) '.') x + in if b == "" + then b + else a ++ tyconModule' (tail b) + where + tyconModule' y = let y' = tyconModule y + in if y' == "" then "" else ('.':y') + + + + +------------------------------------------------------------------------------ +------------------------------------------------------------------------------ +-- +-- Instances of the Data class for Prelude-like types. +-- We define top-level definitions for representations. +-- +------------------------------------------------------------------------------ + + +falseConstr :: Constr +falseConstr = mkConstr boolDataType "False" [] Prefix +trueConstr :: Constr +trueConstr = mkConstr boolDataType "True" [] Prefix + +boolDataType :: DataType +boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr] + +instance Data Bool where + toConstr False = falseConstr + toConstr True = trueConstr + gunfold _ z c = case constrIndex c of + 1 -> z False + 2 -> z True + _ -> error "gunfold" + dataTypeOf _ = boolDataType + + +------------------------------------------------------------------------------ + +charType :: DataType +charType = mkCharType "Prelude.Char" + +instance Data Char where + toConstr x = mkCharConstr charType x + gunfold _ z c = case constrRep c of + (CharConstr x) -> z x + _ -> error "gunfold" + dataTypeOf _ = charType + + +------------------------------------------------------------------------------ + +floatType :: DataType +floatType = mkFloatType "Prelude.Float" + +instance Data Float where + toConstr = mkRealConstr floatType + gunfold _ z c = case constrRep c of + (FloatConstr x) -> z (realToFrac x) + _ -> error "gunfold" + dataTypeOf _ = floatType + + +------------------------------------------------------------------------------ + +doubleType :: DataType +doubleType = mkFloatType "Prelude.Double" + +instance Data Double where + toConstr = mkRealConstr doubleType + gunfold _ z c = case constrRep c of + (FloatConstr x) -> z (realToFrac x) + _ -> error "gunfold" + dataTypeOf _ = doubleType + + +------------------------------------------------------------------------------ + +intType :: DataType +intType = mkIntType "Prelude.Int" + +instance Data Int where + toConstr x = mkIntConstr intType (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = intType + + +------------------------------------------------------------------------------ + +integerType :: DataType +integerType = mkIntType "Prelude.Integer" + +instance Data Integer where + toConstr = mkIntConstr integerType + gunfold _ z c = case constrRep c of + (IntConstr x) -> z x + _ -> error "gunfold" + dataTypeOf _ = integerType + + +------------------------------------------------------------------------------ + +int8Type :: DataType +int8Type = mkIntType "Data.Int.Int8" + +instance Data Int8 where + toConstr x = mkIntConstr int8Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int8Type + + +------------------------------------------------------------------------------ + +int16Type :: DataType +int16Type = mkIntType "Data.Int.Int16" + +instance Data Int16 where + toConstr x = mkIntConstr int16Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int16Type + + +------------------------------------------------------------------------------ + +int32Type :: DataType +int32Type = mkIntType "Data.Int.Int32" + +instance Data Int32 where + toConstr x = mkIntConstr int32Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int32Type + + +------------------------------------------------------------------------------ + +int64Type :: DataType +int64Type = mkIntType "Data.Int.Int64" + +instance Data Int64 where + toConstr x = mkIntConstr int64Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int64Type + + +------------------------------------------------------------------------------ + +wordType :: DataType +wordType = mkIntType "Data.Word.Word" + +instance Data Word where + toConstr x = mkIntConstr wordType (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = wordType + + +------------------------------------------------------------------------------ + +word8Type :: DataType +word8Type = mkIntType "Data.Word.Word8" + +instance Data Word8 where + toConstr x = mkIntConstr word8Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word8Type + + +------------------------------------------------------------------------------ + +word16Type :: DataType +word16Type = mkIntType "Data.Word.Word16" + +instance Data Word16 where + toConstr x = mkIntConstr word16Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word16Type + + +------------------------------------------------------------------------------ + +word32Type :: DataType +word32Type = mkIntType "Data.Word.Word32" + +instance Data Word32 where + toConstr x = mkIntConstr word32Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word32Type + + +------------------------------------------------------------------------------ + +word64Type :: DataType +word64Type = mkIntType "Data.Word.Word64" + +instance Data Word64 where + toConstr x = mkIntConstr word64Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word64Type + + +------------------------------------------------------------------------------ + +ratioConstr :: Constr +ratioConstr = mkConstr ratioDataType ":%" [] Infix + +ratioDataType :: DataType +ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr] + +instance (Data a, Integral a) => Data (Ratio a) where + gfoldl k z (a :% b) = z (:%) `k` a `k` b + toConstr _ = ratioConstr + gunfold k z c | constrIndex c == 1 = k (k (z (:%))) + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = ratioDataType + + +------------------------------------------------------------------------------ + +nilConstr :: Constr +nilConstr = mkConstr listDataType "[]" [] Prefix +consConstr :: Constr +consConstr = mkConstr listDataType "(:)" [] Infix + +listDataType :: DataType +listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr] + +instance Data a => Data [a] where + gfoldl _ z [] = z [] + gfoldl f z (x:xs) = z (:) `f` x `f` xs + toConstr [] = nilConstr + toConstr (_:_) = consConstr + gunfold k z c = case constrIndex c of + 1 -> z [] + 2 -> k (k (z (:))) + _ -> error "gunfold" + dataTypeOf _ = listDataType + dataCast1 f = gcast1 f + +-- +-- The gmaps are given as an illustration. +-- This shows that the gmaps for lists are different from list maps. +-- + gmapT _ [] = [] + gmapT f (x:xs) = (f x:f xs) + gmapQ _ [] = [] + gmapQ f (x:xs) = [f x,f xs] + gmapM _ [] = return [] + gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs') + + +------------------------------------------------------------------------------ + +nothingConstr :: Constr +nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix +justConstr :: Constr +justConstr = mkConstr maybeDataType "Just" [] Prefix + +maybeDataType :: DataType +maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr] + +instance Data a => Data (Maybe a) where + gfoldl _ z Nothing = z Nothing + gfoldl f z (Just x) = z Just `f` x + toConstr Nothing = nothingConstr + toConstr (Just _) = justConstr + gunfold k z c = case constrIndex c of + 1 -> z Nothing + 2 -> k (z Just) + _ -> error "gunfold" + dataTypeOf _ = maybeDataType + dataCast1 f = gcast1 f + + +------------------------------------------------------------------------------ + +ltConstr :: Constr +ltConstr = mkConstr orderingDataType "LT" [] Prefix +eqConstr :: Constr +eqConstr = mkConstr orderingDataType "EQ" [] Prefix +gtConstr :: Constr +gtConstr = mkConstr orderingDataType "GT" [] Prefix + +orderingDataType :: DataType +orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr] + +instance Data Ordering where + gfoldl _ z LT = z LT + gfoldl _ z EQ = z EQ + gfoldl _ z GT = z GT + toConstr LT = ltConstr + toConstr EQ = eqConstr + toConstr GT = gtConstr + gunfold _ z c = case constrIndex c of + 1 -> z LT + 2 -> z EQ + 3 -> z GT + _ -> error "gunfold" + dataTypeOf _ = orderingDataType + + +------------------------------------------------------------------------------ + +leftConstr :: Constr +leftConstr = mkConstr eitherDataType "Left" [] Prefix + +rightConstr :: Constr +rightConstr = mkConstr eitherDataType "Right" [] Prefix + +eitherDataType :: DataType +eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr] + +instance (Data a, Data b) => Data (Either a b) where + gfoldl f z (Left a) = z Left `f` a + gfoldl f z (Right a) = z Right `f` a + toConstr (Left _) = leftConstr + toConstr (Right _) = rightConstr + gunfold k z c = case constrIndex c of + 1 -> k (z Left) + 2 -> k (z Right) + _ -> error "gunfold" + dataTypeOf _ = eitherDataType + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + +tuple0Constr :: Constr +tuple0Constr = mkConstr tuple0DataType "()" [] Prefix + +tuple0DataType :: DataType +tuple0DataType = mkDataType "Prelude.()" [tuple0Constr] + +instance Data () where + toConstr () = tuple0Constr + gunfold _ z c | constrIndex c == 1 = z () + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = tuple0DataType + + +------------------------------------------------------------------------------ + +tuple2Constr :: Constr +tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix + +tuple2DataType :: DataType +tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr] + +instance (Data a, Data b) => Data (a,b) where + gfoldl f z (a,b) = z (,) `f` a `f` b + toConstr (_,_) = tuple2Constr + gunfold k z c | constrIndex c == 1 = k (k (z (,))) + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = tuple2DataType + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + +tuple3Constr :: Constr +tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix + +tuple3DataType :: DataType +tuple3DataType = mkDataType "Prelude.(,,)" [tuple3Constr] + +instance (Data a, Data b, Data c) => Data (a,b,c) where + gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c + toConstr (_,_,_) = tuple3Constr + gunfold k z c | constrIndex c == 1 = k (k (k (z (,,)))) + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = tuple3DataType + + +------------------------------------------------------------------------------ + +tuple4Constr :: Constr +tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix + +tuple4DataType :: DataType +tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr] + +instance (Data a, Data b, Data c, Data d) + => Data (a,b,c,d) where + gfoldl f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d + toConstr (_,_,_,_) = tuple4Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (z (,,,))))) + _ -> error "gunfold" + dataTypeOf _ = tuple4DataType + + +------------------------------------------------------------------------------ + +tuple5Constr :: Constr +tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix + +tuple5DataType :: DataType +tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr] + +instance (Data a, Data b, Data c, Data d, Data e) + => Data (a,b,c,d,e) where + gfoldl f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e + toConstr (_,_,_,_,_) = tuple5Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (z (,,,,)))))) + _ -> error "gunfold" + dataTypeOf _ = tuple5DataType + + +------------------------------------------------------------------------------ + +tuple6Constr :: Constr +tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix + +tuple6DataType :: DataType +tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr] + +instance (Data a, Data b, Data c, Data d, Data e, Data f) + => Data (a,b,c,d,e,f) where + gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' + toConstr (_,_,_,_,_,_) = tuple6Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (k (z (,,,,,))))))) + _ -> error "gunfold" + dataTypeOf _ = tuple6DataType + + +------------------------------------------------------------------------------ + +tuple7Constr :: Constr +tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix + +tuple7DataType :: DataType +tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr] + +instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g) + => Data (a,b,c,d,e,f,g) where + gfoldl f z (a,b,c,d,e,f',g) = + z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g + toConstr (_,_,_,_,_,_,_) = tuple7Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) + _ -> error "gunfold" + dataTypeOf _ = tuple7DataType + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (Ptr a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr" + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (ForeignPtr a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr" + + +------------------------------------------------------------------------------ +-- The Data instance for Array preserves data abstraction at the cost of +-- inefficiency. We omit reflection services for the sake of data abstraction. +instance (Typeable a, Data b, Ix a) => Data (Array a b) + where + gfoldl f z a = z (listArray (bounds a)) `f` (elems a) + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Array.Array" + diff --git a/lib/base/src/Data/Dynamic.hs b/lib/base/src/Data/Dynamic.hs --- a/lib/base/src/Data/Dynamic.hs +++ b/lib/base/src/Data/Dynamic.hs @@ -47,8 +47,8 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Show -import GHC.Err import GHC.Num +import GHC.Exception #endif #ifdef __HUGS__ @@ -92,6 +92,11 @@ showString "<<" . showsPrec 0 t . showString ">>" + +#ifdef __GLASGOW_HASKELL__ +-- here so that it isn't an orphan: +instance Exception Dynamic +#endif #ifdef __GLASGOW_HASKELL__ type Obj = Any diff --git a/lib/base/src/Data/Either.hs b/lib/base/src/Data/Either.hs --- a/lib/base/src/Data/Either.hs +++ b/lib/base/src/Data/Either.hs @@ -79,8 +79,8 @@ partitionEithers :: [Either a b] -> ([a],[b]) partitionEithers = foldr (either left right) ([],[]) where - left a (l, r) = (a:l, r) - right a (l, r) = (l, a:r) + left a ~(l, r) = (a:l, r) + right a ~(l, r) = (l, a:r) {- {-------------------------------------------------------------------- diff --git a/lib/base/src/Data/Eq.hs b/lib/base/src/Data/Eq.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Eq.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Eq +-- Copyright : (c) The University of Glasgow 2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Equality +-- +----------------------------------------------------------------------------- + +module Data.Eq ( + Eq(..), + ) where + +#if __GLASGOW_HASKELL__ +import GHC.Base +#endif diff --git a/lib/base/src/Data/Fixed.hs b/lib/base/src/Data/Fixed.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Fixed.hs @@ -0,0 +1,220 @@ +{-# OPTIONS -Wall -fno-warn-unused-binds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Fixed +-- Copyright : (c) Ashley Yakeley 2005, 2006, 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Ashley Yakeley +-- Stability : experimental +-- Portability : portable +-- +-- This module defines a \"Fixed\" type for fixed-precision arithmetic. +-- The parameter to Fixed is any type that's an instance of HasResolution. +-- HasResolution has a single method that gives the resolution of the Fixed type. +-- +-- This module also contains generalisations of div, mod, and divmod to work +-- with any Real instance. +-- +----------------------------------------------------------------------------- + +module Data.Fixed +( + div',mod',divMod', + + Fixed,HasResolution(..), + showFixed, + E0,Uni, + E1,Deci, + E2,Centi, + E3,Milli, + E6,Micro, + E9,Nano, + E12,Pico +) where + +import Prelude -- necessary to get dependencies right +#ifndef __NHC__ +import Data.Typeable +import Data.Data +#endif + +#ifndef __NHC__ +default () -- avoid any defaulting shenanigans +#endif + +-- | generalisation of 'div' to any instance of Real +div' :: (Real a,Integral b) => a -> a -> b +div' n d = floor ((toRational n) / (toRational d)) + +-- | generalisation of 'divMod' to any instance of Real +divMod' :: (Real a,Integral b) => a -> a -> (b,a) +divMod' n d = (f,n - (fromIntegral f) * d) where + f = div' n d + +-- | generalisation of 'mod' to any instance of Real +mod' :: (Real a) => a -> a -> a +mod' n d = n - (fromInteger f) * d where + f = div' n d + +-- | The type parameter should be an instance of 'HasResolution'. +newtype Fixed a = MkFixed Integer +#ifndef __NHC__ + deriving (Eq,Ord,Typeable) +#else + deriving (Eq,Ord) +#endif + +#ifndef __NHC__ +-- We do this because the automatically derived Data instance requires (Data a) context. +-- Our manual instance has the more general (Typeable a) context. +tyFixed :: DataType +tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed] +conMkFixed :: Constr +conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix +instance (Typeable a) => Data (Fixed a) where + gfoldl k z (MkFixed a) = k (z MkFixed) a + gunfold k z _ = k (z MkFixed) + dataTypeOf _ = tyFixed + toConstr _ = conMkFixed +#endif + +class HasResolution a where + resolution :: p a -> Integer + +withType :: (p a -> f a) -> f a +withType foo = foo undefined + +withResolution :: (HasResolution a) => (Integer -> f a) -> f a +withResolution foo = withType (foo . resolution) + +instance Enum (Fixed a) where + succ (MkFixed a) = MkFixed (succ a) + pred (MkFixed a) = MkFixed (pred a) + toEnum = MkFixed . toEnum + fromEnum (MkFixed a) = fromEnum a + enumFrom (MkFixed a) = fmap MkFixed (enumFrom a) + enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b) + enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b) + enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c) + +instance (HasResolution a) => Num (Fixed a) where + (MkFixed a) + (MkFixed b) = MkFixed (a + b) + (MkFixed a) - (MkFixed b) = MkFixed (a - b) + fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa)) + negate (MkFixed a) = MkFixed (negate a) + abs (MkFixed a) = MkFixed (abs a) + signum (MkFixed a) = fromInteger (signum a) + fromInteger i = withResolution (\res -> MkFixed (i * res)) + +instance (HasResolution a) => Real (Fixed a) where + toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa)) + +instance (HasResolution a) => Fractional (Fixed a) where + fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b) + recip fa@(MkFixed a) = MkFixed (div (res * res) a) where + res = resolution fa + fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res)))) + +instance (HasResolution a) => RealFrac (Fixed a) where + properFraction a = (i,a - (fromIntegral i)) where + i = truncate a + truncate f = truncate (toRational f) + round f = round (toRational f) + ceiling f = ceiling (toRational f) + floor f = floor (toRational f) + +chopZeros :: Integer -> String +chopZeros 0 = "" +chopZeros a | mod a 10 == 0 = chopZeros (div a 10) +chopZeros a = show a + +-- only works for positive a +showIntegerZeros :: Bool -> Int -> Integer -> String +showIntegerZeros True _ 0 = "" +showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where + s = show a + s' = if chopTrailingZeros then chopZeros a else s + +withDot :: String -> String +withDot "" = "" +withDot s = '.':s + +-- | First arg is whether to chop off trailing zeros +showFixed :: (HasResolution a) => Bool -> Fixed a -> String +showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa)) +showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where + res = resolution fa + (i,d) = divMod a res + -- enough digits to be unambiguous + digits = ceiling (logBase 10 (fromInteger res) :: Double) + maxnum = 10 ^ digits + fracNum = div (d * maxnum) res + +instance (HasResolution a) => Show (Fixed a) where + show = showFixed False + + +data E0 = E0 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E0 where + resolution _ = 1 +-- | resolution of 1, this works the same as Integer +type Uni = Fixed E0 + +data E1 = E1 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E1 where + resolution _ = 10 +-- | resolution of 10^-1 = .1 +type Deci = Fixed E1 + +data E2 = E2 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E2 where + resolution _ = 100 +-- | resolution of 10^-2 = .01, useful for many monetary currencies +type Centi = Fixed E2 + +data E3 = E3 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E3 where + resolution _ = 1000 +-- | resolution of 10^-3 = .001 +type Milli = Fixed E3 + +data E6 = E6 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E6 where + resolution _ = 1000000 +-- | resolution of 10^-6 = .000001 +type Micro = Fixed E6 + +data E9 = E9 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E9 where + resolution _ = 1000000000 +-- | resolution of 10^-9 = .000000001 +type Nano = Fixed E9 + +data E12 = E12 +#ifndef __NHC__ + deriving (Typeable) +#endif +instance HasResolution E12 where + resolution _ = 1000000000000 +-- | resolution of 10^-12 = .000000000001 +type Pico = Fixed E12 diff --git a/lib/base/src/Data/Foldable.hs b/lib/base/src/Data/Foldable.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Foldable.hs @@ -0,0 +1,309 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Foldable +-- Copyright : Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be folded to a summary value. +-- +-- Many of these functions generalize "Prelude", "Control.Monad" and +-- "Data.List" functions of the same names from lists to any 'Foldable' +-- functor. To avoid ambiguity, either import those modules hiding +-- these names or qualify uses of these function names with an alias +-- for this module. + +module Data.Foldable ( + -- * Folds + Foldable(..), + -- ** Special biased folds + foldr', + foldl', + foldrM, + foldlM, + -- ** Folding actions + -- *** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- *** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- ** Specialized folds + toList, + concat, + concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + maximumBy, + minimum, + minimumBy, + -- ** Searches + elem, + notElem, + find + ) where + +import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, + elem, notElem, concat, concatMap, and, or, any, all, + sum, product, maximum, minimum) +import qualified Prelude (foldl, foldr, foldl1, foldr1) +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid + +#ifdef __NHC__ +import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (build) +#endif + +#if defined(__GLASGOW_HASKELL__) +import GHC.Arr +#elif defined(__HUGS__) +import Hugs.Array +#elif defined(__NHC__) +import Array +#endif + +-- | Data structures that can be folded. +-- +-- Minimal complete definition: 'foldMap' or 'foldr'. +-- +-- For example, given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Foldable Tree +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r +-- +-- This is suitable even for abstract types, as the monoid is assumed +-- to satisfy the monoid laws. +-- +class Foldable t where + -- | Combine the elements of a structure using a monoid. + fold :: Monoid m => t m -> m + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t a -> m + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + foldr :: (a -> b -> b) -> b -> t a -> b + foldr f z t = appEndo (foldMap (Endo . f) t) z + + -- | Left-associative fold of a structure. + -- + -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + foldl :: (a -> b -> a) -> a -> t b -> a + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t a -> a + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where mf x Nothing = Just x + mf x (Just y) = Just (f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t a -> a + foldl1 f xs = fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) + where mf Nothing y = Just y + mf (Just x) y = Just (f x y) + +-- instances for Prelude types + +instance Foldable Maybe where + foldr _ z Nothing = z + foldr f z (Just x) = f x z + + foldl _ z Nothing = z + foldl f z (Just x) = f z x + +instance Foldable [] where + foldr = Prelude.foldr + foldl = Prelude.foldl + foldr1 = Prelude.foldr1 + foldl1 = Prelude.foldl1 + +instance Ix i => Foldable (Array i) where + foldr f z = Prelude.foldr f z . elems + +-- | Fold over the elements of a structure, +-- associating to the right, but strictly. +foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b +foldr' f z0 xs = foldl f' id xs z0 + where f' k x z = k $! f x z + +-- | Monadic fold over the elements of a structure, +-- associating to the right, i.e. from right to left. +foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b +foldrM f z0 xs = foldl f' return xs z0 + where f' k x z = f x z >>= k + +-- | Fold over the elements of a structure, +-- associating to the left, but strictly. +foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a +foldl' f z0 xs = foldr f' id xs z0 + where f' x k z = k $! f z x + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a +foldlM f z0 xs = foldr f' return xs z0 + where f' x k z = f z x >>= k + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +traverse_ f = foldr ((*>) . f) (pure ()) + +-- | 'for_' is 'traverse_' with its arguments flipped. +for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to a monadic action, evaluate +-- these actions from left to right, and ignore the results. +mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () +mapM_ f = foldr ((>>) . f) (return ()) + +-- | 'forM_' is 'mapM_' with its arguments flipped. +forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | Evaluate each action in the structure from left to right, +-- and ignore the results. +sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | Evaluate each monadic action in the structure from left to right, +-- and ignore the results. +sequence_ :: (Foldable t, Monad m) => t (m a) -> m () +sequence_ = foldr (>>) (return ()) + +-- | The sum of a collection of actions, generalizing 'concat'. +asum :: (Foldable t, Alternative f) => t (f a) -> f a +{-# INLINE asum #-} +asum = foldr (<|>) empty + +-- | The sum of a collection of actions, generalizing 'concat'. +msum :: (Foldable t, MonadPlus m) => t (m a) -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +-- These use foldr rather than foldMap to avoid repeated concatenation. + +-- | List of elements of a structure. +toList :: Foldable t => t a -> [a] +{-# INLINE toList #-} +#ifdef __GLASGOW_HASKELL__ +toList t = build (\ c n -> foldr c n t) +#else +toList = foldr (:) [] +#endif + +-- | The concatenation of all the elements of a container of lists. +concat :: Foldable t => t [a] -> [a] +concat = fold + +-- | Map a function over all the elements of a container and concatenate +-- the resulting lists. +concatMap :: Foldable t => (a -> [b]) -> t a -> [b] +concatMap = foldMap + +-- | 'and' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +and :: Foldable t => t Bool -> Bool +and = getAll . foldMap All + +-- | 'or' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +or :: Foldable t => t Bool -> Bool +or = getAny . foldMap Any + +-- | Determines whether any element of the structure satisfies the predicate. +any :: Foldable t => (a -> Bool) -> t a -> Bool +any p = getAny . foldMap (Any . p) + +-- | Determines whether all elements of the structure satisfy the predicate. +all :: Foldable t => (a -> Bool) -> t a -> Bool +all p = getAll . foldMap (All . p) + +-- | The 'sum' function computes the sum of the numbers of a structure. +sum :: (Foldable t, Num a) => t a -> a +sum = getSum . foldMap Sum + +-- | The 'product' function computes the product of the numbers of a structure. +product :: (Foldable t, Num a) => t a -> a +product = getProduct . foldMap Product + +-- | The largest element of a non-empty structure. +maximum :: (Foldable t, Ord a) => t a -> a +maximum = foldr1 max + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +maximumBy cmp = foldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure. +minimum :: (Foldable t, Ord a) => t a -> a +minimum = foldr1 min + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +minimumBy cmp = foldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | Does the element occur in the structure? +elem :: (Foldable t, Eq a) => a -> t a -> Bool +elem = any . (==) + +-- | 'notElem' is the negation of 'elem'. +notElem :: (Foldable t, Eq a) => a -> t a -> Bool +notElem x = not . elem x + +-- | The 'find' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +find :: Foldable t => (a -> Bool) -> t a -> Maybe a +find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) diff --git a/lib/base/src/Data/Function.hs b/lib/base/src/Data/Function.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Function.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Function +-- Copyright : Nils Anders Danielsson 2006 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple combinators working solely on and with functions. + +module Data.Function + ( -- * "Prelude" re-exports + id, const, (.), flip, ($) + -- * Other combinators + , fix + , on + ) where + +import Prelude + +infixl 0 `on` + +-- | @'fix' f@ is the least fixed point of the function @f@, +-- i.e. the least defined @x@ such that @f x = x@. +fix :: (a -> a) -> a +fix f = let x = f x in x + +-- | @(*) \`on\` f = \\x y -> f x * f y@. +-- +-- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@. +-- +-- Algebraic properties: +-- +-- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@) +-- +-- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@ +-- +-- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@ + +-- Proofs (so that I don't have to edit the test-suite): + +-- (*) `on` id +-- = +-- \x y -> id x * id y +-- = +-- \x y -> x * y +-- = { If (*) /= _|_ or const _|_. } +-- (*) + +-- (*) `on` f `on` g +-- = +-- ((*) `on` f) `on` g +-- = +-- \x y -> ((*) `on` f) (g x) (g y) +-- = +-- \x y -> (\x y -> f x * f y) (g x) (g y) +-- = +-- \x y -> f (g x) * f (g y) +-- = +-- \x y -> (f . g) x * (f . g) y +-- = +-- (*) `on` (f . g) +-- = +-- (*) `on` f . g + +-- flip on f . flip on g +-- = +-- (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g +-- = +-- (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g) +-- = +-- \(*) -> (*) `on` g `on` f +-- = { See above. } +-- \(*) -> (*) `on` g . f +-- = +-- (\h (*) -> (*) `on` h) (g . f) +-- = +-- flip on (g . f) + +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +(.*.) `on` f = \x y -> f x .*. f y diff --git a/lib/base/src/Data/Functor.hs b/lib/base/src/Data/Functor.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Functor.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functors: uniform action over a parameterized type, generalizing the +-- 'map' function on lists. + +module Data.Functor + ( + Functor(fmap), + (<$), + (<$>), + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base (Functor(..)) +#else +(<$) :: Functor f => a -> f b -> f a +(<$) = fmap . const +#endif + +infixl 4 <$> + +-- | An infix synonym for 'fmap'. +(<$>) :: Functor f => (a -> b) -> f a -> f b +(<$>) = fmap diff --git a/lib/base/src/Data/HashTable.hs b/lib/base/src/Data/HashTable.hs --- a/lib/base/src/Data/HashTable.hs +++ b/lib/base/src/Data/HashTable.hs @@ -50,9 +50,9 @@ import GHC.Show ( Show(..) ) import GHC.Int ( Int64 ) -import GHC.IOBase ( IO, IOArray, newIOArray, - unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO, - IORef, newIORef, readIORef, writeIORef ) +import GHC.IO +import GHC.IOArray +import GHC.IORef #else import Data.Char ( ord ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) @@ -77,27 +77,16 @@ readHTArray :: HTArray a -> Int32 -> IO a writeMutArray :: MutArray a -> Int32 -> a -> IO () -freezeArray :: MutArray a -> IO (HTArray a) -thawArray :: HTArray a -> IO (MutArray a) newMutArray :: (Int32, Int32) -> a -> IO (MutArray a) -#if defined(DEBUG) || defined(__NHC__) +newMutArray = newIOArray type MutArray a = IOArray Int32 a type HTArray a = MutArray a -newMutArray = newIOArray +#if defined(DEBUG) || defined(__NHC__) readHTArray = readIOArray writeMutArray = writeIOArray -freezeArray = return -thawArray = return #else -type MutArray a = IOArray Int32 a -type HTArray a = MutArray a -- Array Int32 a -newMutArray = newIOArray -readHTArray arr i = readMutArray arr i -- return $! (unsafeAt arr (fromIntegral i)) -readMutArray :: MutArray a -> Int32 -> IO a -readMutArray arr i = unsafeReadIOArray arr (fromIntegral i) +readHTArray arr i = unsafeReadIOArray arr (fromIntegral i) writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x -freezeArray = return -- unsafeFreeze -thawArray = return -- unsafeThaw #endif data HashTable key val = HashTable { @@ -147,19 +136,19 @@ | otherwise = return () recordNew :: IO () -recordNew = instrument rec - where rec hd@HD{ tables=t, totBuckets=b } = +recordNew = instrument rec' + where rec' hd@HD{ tables=t, totBuckets=b } = hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN } recordIns :: Int32 -> Int32 -> [a] -> IO () -recordIns i sz bkt = instrument rec - where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } = +recordIns i sz bkt = instrument rec' + where rec' hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } = hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz, maxChain=mc `max` length bkt } recordResize :: Int32 -> Int32 -> IO () -recordResize older newer = instrument rec - where rec hd@HD{ totBuckets=b, maxBuckets=mx } = +recordResize older newer = instrument rec' + where rec' hd@HD{ totBuckets=b, maxBuckets=mx } = hd{ totBuckets=b+fromIntegral (newer-older), maxBuckets=mx `max` newer } @@ -284,12 +273,11 @@ new cmpr hash = do recordNew -- make a new hash table with a single, empty, segment - let mask = tABLE_MIN-1 - bkts' <- newMutArray (0,mask) [] - bkts <- freezeArray bkts' + let mask = tABLE_MIN-1 :: Int32 + bkts <- newMutArray (0,mask) [] let - kcnt = 0 + kcnt = 0 :: Int32 ht = HT { buckets=bkts, kcount=kcnt, bmask=mask } table <- newIORef ht @@ -369,9 +357,7 @@ (bckt', inserts, result) <- return $ bucketFn bckt let k' = k + inserts table1 = table { kcount=k' } - bkts' <- thawArray bkts - writeMutArray bkts' indx bckt' - freezeArray bkts' + writeMutArray bkts indx bckt' table2 <- if canEnlarge == CanInsert && inserts > 0 then do recordIns inserts k' bckt' if tooBig k' b @@ -384,26 +370,24 @@ expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val) expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do let - oldsize = mask + 1 - newmask = mask + mask + 1 + oldsize = mask + 1 :: Int32 + newmask = mask + mask + 1 :: Int32 recordResize oldsize (newmask+1) -- if newmask > tABLE_MAX-1 then return table else do -- - newbkts' <- newMutArray (0,newmask) [] + newbkts <- newMutArray (0,newmask) [] let splitBucket oldindex = do bucket <- readHTArray bkts oldindex let (oldb,newb) = partition ((oldindex==). bucketIndex newmask . hash . fst) bucket - writeMutArray newbkts' oldindex oldb - writeMutArray newbkts' (oldindex + oldsize) newb + writeMutArray newbkts oldindex oldb + writeMutArray newbkts (oldindex + oldsize) newb mapM_ splitBucket [0..mask] - - newbkts <- freezeArray newbkts' return ( table{ buckets=newbkts, bmask=newmask } ) diff --git a/lib/base/src/Data/IORef.hs b/lib/base/src/Data/IORef.hs --- a/lib/base/src/Data/IORef.hs +++ b/lib/base/src/Data/IORef.hs @@ -23,7 +23,7 @@ modifyIORef, -- :: IORef a -> (a -> a) -> IO () atomicModifyIORef, -- :: IORef a -> (a -> (a,b)) -> IO b -#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__) && !defined(__LHC__) +#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__) mkWeakIORef, -- :: IORef a -> IO () -> IO (Weak (IORef a)) #endif ) where @@ -35,8 +35,10 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.STRef -import GHC.IOBase -#if !defined(__PARALLEL_HASKELL__) && !defined(__LHC__) +-- import GHC.IO +import GHC.IORef hiding (atomicModifyIORef) +import qualified GHC.IORef +#if !defined(__PARALLEL_HASKELL__) import GHC.Weak #endif #endif /* __GLASGOW_HASKELL__ */ @@ -51,7 +53,7 @@ ) #endif -#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__) && !defined(__LHC__) +#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__) -- |Make a 'Weak' pointer to an 'IORef' mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a)) mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s -> @@ -75,7 +77,7 @@ -- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b #if defined(__GLASGOW_HASKELL__) -atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s +atomicModifyIORef = GHC.IORef.atomicModifyIORef #elif defined(__HUGS__) atomicModifyIORef = plainModifyIORef -- Hugs has no preemption diff --git a/lib/base/src/Data/Ix.hs b/lib/base/src/Data/Ix.hs --- a/lib/base/src/Data/Ix.hs +++ b/lib/base/src/Data/Ix.hs @@ -60,7 +60,7 @@ ) where -import Prelude +-- import Prelude #ifdef __GLASGOW_HASKELL__ import GHC.Arr diff --git a/lib/base/src/Data/List.hs b/lib/base/src/Data/List.hs --- a/lib/base/src/Data/List.hs +++ b/lib/base/src/Data/List.hs @@ -399,6 +399,9 @@ -- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4] -- -- If the first list contains duplicates, so will the result. +-- +-- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4] +-- -- It is a special case of 'intersectBy', which allows the programmer to -- supply their own equality test. @@ -568,6 +571,17 @@ genericLength [] = 0 genericLength (_:l) = 1 + genericLength l +{-# RULES + "genericLengthInt" genericLength = (strictGenericLength :: [a] -> Int); + "genericLengthInteger" genericLength = (strictGenericLength :: [a] -> Integer); + #-} + +strictGenericLength :: (Num i) => [b] -> i +strictGenericLength l = gl l 0 + where + gl [] a = a + gl (_:xs) a = let a' = a + 1 in a' `seq` gl xs a' + -- | The 'genericTake' function is an overloaded version of 'take', which -- accepts any 'Integral' value as the number of elements to take. genericTake :: (Integral i) => i -> [a] -> [a] @@ -779,10 +793,50 @@ sortBy cmp = foldr (insertBy cmp) [] #else +{- +GHC's mergesort replaced by a better implementation, 24/12/2009. +This code originally contributed to the nhc12 compiler by Thomas Nordin +in 2002. Rumoured to have been based on code by Lennart Augustsson, e.g. + http://www.mail-archive.com/haskell@haskell.org/msg01822.html +and possibly to bear similarities to a 1982 paper by Richard O'Keefe: +"A smooth applicative merge sort". + +Benchmarks show it to be often 2x the speed of the previous implementation. +Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/2143 +-} + +sort = sortBy compare +sortBy cmp = mergeAll . sequences + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs + ascending a as bs = as [a]: sequences bs + + mergeAll [x] = x + mergeAll xs = mergeAll (mergePairs xs) + + mergePairs (a:b:xs) = merge a b: mergePairs xs + mergePairs xs = xs + + merge as@(a:as') bs@(b:bs') + | a `cmp` b == GT = b:merge as bs' + | otherwise = a:merge as' bs + merge [] bs = bs + merge as [] = as + +{- sortBy cmp l = mergesort cmp l sort l = mergesort compare l -{- Quicksort replaced by mergesort, 14/5/2002. From: Ian Lynagh @@ -823,7 +877,6 @@ func 100000 sorted mergesort 2.23 func 100000 revsorted sort 5872.34 func 100000 revsorted mergesort 2.24 --} mergesort :: (a -> a -> Ordering) -> [a] -> [a] mergesort cmp = mergesort' cmp . map wrap @@ -849,8 +902,9 @@ wrap :: a -> [a] wrap x = [x] -{- -OLD: qsort version + + +OLDER: qsort version -- qsort is stable and does not concatenate. qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] diff --git a/lib/base/src/Data/Monoid.hs b/lib/base/src/Data/Monoid.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Monoid.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Monoid +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A class for monoids (types with an associative binary operation that +-- has an identity) with various general-purpose instances. +----------------------------------------------------------------------------- + +module Data.Monoid ( + -- * Monoid typeclass + Monoid(..), + Dual(..), + Endo(..), + -- * Bool wrappers + All(..), + Any(..), + -- * Num wrappers + Sum(..), + Product(..), + -- * Maybe wrappers + -- $MaybeExamples + First(..), + Last(..) + ) where + +import Prelude + +{- +-- just for testing +import Data.Maybe +import Test.QuickCheck +-- -} + +-- --------------------------------------------------------------------------- +-- | The class of monoids (types with an associative binary operation that +-- has an identity). Instances should satisfy the following laws: +-- +-- * @mappend mempty x = x@ +-- +-- * @mappend x mempty = x@ +-- +-- * @mappend x (mappend y z) = mappend (mappend x y) z@ +-- +-- * @mconcat = 'foldr' mappend mempty@ +-- +-- The method names refer to the monoid of lists under concatenation, +-- but there are many other instances. +-- +-- Minimal complete definition: 'mempty' and 'mappend'. +-- +-- Some types can be viewed as a monoid in more than one way, +-- e.g. both addition and multiplication on numbers. +-- In such cases we often define @newtype@s and make those instances +-- of 'Monoid', e.g. 'Sum' and 'Product'. + +class Monoid a where + mempty :: a + -- ^ Identity of 'mappend' + mappend :: a -> a -> a + -- ^ An associative operation + mconcat :: [a] -> a + + -- ^ Fold a list using the monoid. + -- For most types, the default definition for 'mconcat' will be + -- used, but the function is included in the class definition so + -- that an optimized version can be provided for specific types. + + mconcat = foldr mappend mempty + +-- Monoid instances. + +instance Monoid [a] where + mempty = [] + mappend = (++) + +instance Monoid b => Monoid (a -> b) where + mempty _ = mempty + mappend f g x = f x `mappend` g x + +instance Monoid () where + -- Should it be strict? + mempty = () + _ `mappend` _ = () + mconcat _ = () + +instance (Monoid a, Monoid b) => Monoid (a,b) where + mempty = (mempty, mempty) + (a1,b1) `mappend` (a2,b2) = + (a1 `mappend` a2, b1 `mappend` b2) + +instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where + mempty = (mempty, mempty, mempty) + (a1,b1,c1) `mappend` (a2,b2,c2) = + (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) + +instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where + mempty = (mempty, mempty, mempty, mempty) + (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) = + (a1 `mappend` a2, b1 `mappend` b2, + c1 `mappend` c2, d1 `mappend` d2) + +instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => + Monoid (a,b,c,d,e) where + mempty = (mempty, mempty, mempty, mempty, mempty) + (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) = + (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, + d1 `mappend` d2, e1 `mappend` e2) + +-- lexicographical ordering +instance Monoid Ordering where + mempty = EQ + LT `mappend` _ = LT + EQ `mappend` y = y + GT `mappend` _ = GT + +-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. +newtype Dual a = Dual { getDual :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid a => Monoid (Dual a) where + mempty = Dual mempty + Dual x `mappend` Dual y = Dual (y `mappend` x) + +-- | The monoid of endomorphisms under composition. +newtype Endo a = Endo { appEndo :: a -> a } + +instance Monoid (Endo a) where + mempty = Endo id + Endo f `mappend` Endo g = Endo (f . g) + +-- | Boolean monoid under conjunction. +newtype All = All { getAll :: Bool } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid All where + mempty = All True + All x `mappend` All y = All (x && y) + +-- | Boolean monoid under disjunction. +newtype Any = Any { getAny :: Bool } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid Any where + mempty = Any False + Any x `mappend` Any y = Any (x || y) + +-- | Monoid under addition. +newtype Sum a = Sum { getSum :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Num a => Monoid (Sum a) where + mempty = Sum 0 + Sum x `mappend` Sum y = Sum (x + y) + +-- | Monoid under multiplication. +newtype Product a = Product { getProduct :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Num a => Monoid (Product a) where + mempty = Product 1 + Product x `mappend` Product y = Product (x * y) + +-- $MaybeExamples +-- To implement @find@ or @findLast@ on any 'Foldable': +-- +-- @ +-- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a +-- findLast pred = getLast . foldMap (\x -> if pred x +-- then Last (Just x) +-- else Last Nothing) +-- @ +-- +-- Much of Data.Map's interface can be implemented with +-- Data.Map.alter. Some of the rest can be implemented with a new +-- @alterA@ function and either 'First' or 'Last': +-- +-- > alterA :: (Applicative f, Ord k) => +-- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) +-- > +-- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative +-- +-- @ +-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v +-- -> Map k v -> (Maybe v, Map k v) +-- insertLookupWithKey combine key value = +-- Arrow.first getFirst . alterA doChange key +-- where +-- doChange Nothing = (First Nothing, Just value) +-- doChange (Just oldValue) = +-- (First (Just oldValue), +-- Just (combine key value oldValue)) +-- @ + +-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to +-- : \"Any semigroup @S@ may be +-- turned into a monoid simply by adjoining an element @e@ not in @S@ +-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since +-- there is no \"Semigroup\" typeclass providing just 'mappend', we +-- use 'Monoid' instead. +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) + + +-- | Maybe monoid returning the leftmost non-Nothing value. +newtype First a = First { getFirst :: Maybe a } +#ifndef __HADDOCK__ + deriving (Eq, Ord, Read, Show) +#else /* __HADDOCK__ */ +instance Eq a => Eq (First a) +instance Ord a => Ord (First a) +instance Read a => Read (First a) +instance Show a => Show (First a) +#endif + +instance Monoid (First a) where + mempty = First Nothing + r@(First (Just _)) `mappend` _ = r + First Nothing `mappend` r = r + +-- | Maybe monoid returning the rightmost non-Nothing value. +newtype Last a = Last { getLast :: Maybe a } +#ifndef __HADDOCK__ + deriving (Eq, Ord, Read, Show) +#else /* __HADDOCK__ */ +instance Eq a => Eq (Last a) +instance Ord a => Ord (Last a) +instance Read a => Read (Last a) +instance Show a => Show (Last a) +#endif + +instance Monoid (Last a) where + mempty = Last Nothing + _ `mappend` r@(Last (Just _)) = r + r `mappend` Last Nothing = r + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [return Nothing, Just `fmap` arbitrary] + +prop_mconcatMaybe :: [Maybe [Int]] -> Bool +prop_mconcatMaybe x = + fromMaybe [] (mconcat x) == mconcat (catMaybes x) + +prop_mconcatFirst :: [Maybe Int] -> Bool +prop_mconcatFirst x = + getFirst (mconcat (map First x)) == listToMaybe (catMaybes x) +prop_mconcatLast :: [Maybe Int] -> Bool +prop_mconcatLast x = + getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x) + where listLastToMaybe [] = Nothing + listLastToMaybe lst = Just (last lst) +-- -} diff --git a/lib/base/src/Data/Ord.hs b/lib/base/src/Data/Ord.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Ord.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Ord +-- Copyright : (c) The University of Glasgow 2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Orderings +-- +----------------------------------------------------------------------------- + +module Data.Ord ( + Ord(..), + Ordering(..), + comparing, + ) where + +#if __GLASGOW_HASKELL__ +import GHC.Base +#endif + +-- | +-- > comparing p x y = compare (p x) (p y) +-- +-- Useful combinator for use in conjunction with the @xxxBy@ family +-- of functions from "Data.List", for example: +-- +-- > ... sortBy (comparing fst) ... +comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering +comparing p x y = compare (p x) (p y) diff --git a/lib/base/src/Data/Ratio.hs b/lib/base/src/Data/Ratio.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Ratio.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Ratio +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Standard functions on rational numbers +-- +----------------------------------------------------------------------------- + +module Data.Ratio + ( Ratio + , Rational + , (%) -- :: (Integral a) => a -> a -> Ratio a + , numerator -- :: (Integral a) => Ratio a -> a + , denominator -- :: (Integral a) => Ratio a -> a + , approxRational -- :: (RealFrac a) => a -> a -> Rational + + -- Ratio instances: + -- (Integral a) => Eq (Ratio a) + -- (Integral a) => Ord (Ratio a) + -- (Integral a) => Num (Ratio a) + -- (Integral a) => Real (Ratio a) + -- (Integral a) => Fractional (Ratio a) + -- (Integral a) => RealFrac (Ratio a) + -- (Integral a) => Enum (Ratio a) + -- (Read a, Integral a) => Read (Ratio a) + -- (Integral a) => Show (Ratio a) + + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.Real -- The basic defns for Ratio +#endif + +#ifdef __HUGS__ +import Hugs.Prelude(Ratio(..), (%), numerator, denominator) +#endif + +#ifdef __NHC__ +import Ratio (Ratio(..), (%), numerator, denominator, approxRational) +#else + +-- ----------------------------------------------------------------------------- +-- approxRational + +-- | 'approxRational', applied to two real fractional numbers @x@ and @epsilon@, +-- returns the simplest rational number within @epsilon@ of @x@. +-- A rational number @y@ is said to be /simpler/ than another @y'@ if +-- +-- * @'abs' ('numerator' y) <= 'abs' ('numerator' y')@, and +-- +-- * @'denominator' y <= 'denominator' y'@. +-- +-- Any real interval contains a unique simplest rational; +-- in particular, note that @0\/1@ is the simplest rational of all. + +-- Implementation details: Here, for simplicity, we assume a closed rational +-- interval. If such an interval includes at least one whole number, then +-- the simplest rational is the absolutely least whole number. Otherwise, +-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of +-- the simplest rational between d'%r' and d%r. + +approxRational :: (RealFrac a) => a -> a -> Rational +approxRational rat eps = simplest (rat-eps) (rat+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr = toRational x + n = numerator xr + d = denominator xr + nd' = toRational y + n' = numerator nd' + d' = denominator nd' + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + nd'' = simplest' d' r' d r + n'' = numerator nd'' + d'' = denominator nd'' +#endif diff --git a/lib/base/src/Data/STRef.hs b/lib/base/src/Data/STRef.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/STRef.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.STRef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.ST) +-- +-- Mutable references in the (strict) ST monad. +-- +----------------------------------------------------------------------------- + +module Data.STRef ( + -- * STRefs + STRef, -- abstract, instance Eq + newSTRef, -- :: a -> ST s (STRef s a) + readSTRef, -- :: STRef s a -> ST s a + writeSTRef, -- :: STRef s a -> a -> ST s () + modifySTRef -- :: STRef s a -> (a -> a) -> ST s () + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.ST +import GHC.STRef +#endif + +#ifdef __HUGS__ +import Hugs.ST +import Data.Typeable + +#include "Typeable.h" +INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") +#endif + +-- |Mutate the contents of an 'STRef' +modifySTRef :: STRef s a -> (a -> a) -> ST s () +modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref diff --git a/lib/base/src/Data/STRef/Lazy.hs b/lib/base/src/Data/STRef/Lazy.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/STRef/Lazy.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.STRef.Lazy +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.ST.Lazy) +-- +-- Mutable references in the lazy ST monad. +-- +----------------------------------------------------------------------------- +module Data.STRef.Lazy ( + -- * STRefs + ST.STRef, -- abstract, instance Eq + newSTRef, -- :: a -> ST s (STRef s a) + readSTRef, -- :: STRef s a -> ST s a + writeSTRef, -- :: STRef s a -> a -> ST s () + modifySTRef -- :: STRef s a -> (a -> a) -> ST s () + ) where + +import Control.Monad.ST.Lazy +import qualified Data.STRef as ST +import Prelude + +newSTRef :: a -> ST s (ST.STRef s a) +readSTRef :: ST.STRef s a -> ST s a +writeSTRef :: ST.STRef s a -> a -> ST s () +modifySTRef :: ST.STRef s a -> (a -> a) -> ST s () + +newSTRef = strictToLazyST . ST.newSTRef +readSTRef = strictToLazyST . ST.readSTRef +writeSTRef r a = strictToLazyST (ST.writeSTRef r a) +modifySTRef r f = strictToLazyST (ST.modifySTRef r f) diff --git a/lib/base/src/Data/STRef/Strict.hs b/lib/base/src/Data/STRef/Strict.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/STRef/Strict.hs @@ -0,0 +1,19 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.STRef.Strict +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (uses Control.Monad.ST.Strict) +-- +-- Mutable references in the (strict) ST monad (re-export of "Data.STRef") +-- +----------------------------------------------------------------------------- + +module Data.STRef.Strict ( + module Data.STRef + ) where + +import Data.STRef diff --git a/lib/base/src/Data/String.hs b/lib/base/src/Data/String.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/String.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.String +-- Copyright : (c) The University of Glasgow 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Things related to the String type. +-- +----------------------------------------------------------------------------- + +module Data.String ( + IsString(..) + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#endif + +-- | Class for string-like datastructures; used by the overloaded string +-- extension (-foverloaded-strings in GHC). +class IsString a where + fromString :: String -> a + +instance IsString [Char] where + fromString xs = xs + diff --git a/lib/base/src/Data/Traversable.hs b/lib/base/src/Data/Traversable.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Traversable.hs @@ -0,0 +1,190 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Traversable +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be traversed from left to right, +-- performing an action on each element. +-- +-- See also +-- +-- * /Applicative Programming with Effects/, +-- by Conor McBride and Ross Paterson, online at +-- . +-- +-- * /The Essence of the Iterator Pattern/, +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, and online at +-- . +-- +-- Note that the functions 'mapM' and 'sequence' generalize "Prelude" +-- functions of the same names from lists to any 'Traversable' functor. +-- To avoid ambiguity, either import the "Prelude" hiding these names +-- or qualify uses of these function names with an alias for this module. + +module Data.Traversable ( + Traversable(..), + for, + forM, + mapAccumL, + mapAccumR, + fmapDefault, + foldMapDefault, + ) where + +import Prelude hiding (mapM, sequence, foldr) +import qualified Prelude (mapM, foldr) +import Control.Applicative +import Data.Foldable (Foldable()) +import Data.Monoid (Monoid) + +#if defined(__GLASGOW_HASKELL__) +import GHC.Arr +#elif defined(__HUGS__) +import Hugs.Array +#elif defined(__NHC__) +import Array +#endif + +-- | Functors representing data structures that can be traversed from +-- left to right. +-- +-- Minimal complete definition: 'traverse' or 'sequenceA'. +-- +-- Instances are similar to 'Functor', e.g. given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Traversable Tree +-- > traverse f Empty = pure Empty +-- > traverse f (Leaf x) = Leaf <$> f x +-- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r +-- +-- This is suitable even for abstract types, as the laws for '<*>' +-- imply a form of associativity. +-- +-- The superclass instances should satisfy the following: +-- +-- * In the 'Functor' instance, 'fmap' should be equivalent to traversal +-- with the identity applicative functor ('fmapDefault'). +-- +-- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be +-- equivalent to traversal with a constant applicative functor +-- ('foldMapDefault'). +-- +class (Functor t, Foldable t) => Traversable t where + -- | Map each element of a structure to an action, evaluate + -- these actions from left to right, and collect the results. + traverse :: Applicative f => (a -> f b) -> t a -> f (t b) + traverse f = sequenceA . fmap f + + -- | Evaluate each action in the structure from left to right, + -- and collect the results. + sequenceA :: Applicative f => t (f a) -> f (t a) + sequenceA = traverse id + + -- | Map each element of a structure to a monadic action, evaluate + -- these actions from left to right, and collect the results. + mapM :: Monad m => (a -> m b) -> t a -> m (t b) + mapM f = unwrapMonad . traverse (WrapMonad . f) + + -- | Evaluate each monadic action in the structure from left to right, + -- and collect the results. + sequence :: Monad m => t (m a) -> m (t a) + sequence = mapM id + +-- instances for Prelude types + +instance Traversable Maybe where + traverse _ Nothing = pure Nothing + traverse f (Just x) = Just <$> f x + +instance Traversable [] where + traverse f = Prelude.foldr cons_f (pure []) + where cons_f x ys = (:) <$> f x <*> ys + + mapM = Prelude.mapM + +instance Ix i => Traversable (Array i) where + traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr) + +-- general functions + +-- | 'for' is 'traverse' with its arguments flipped. +for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) +{-# INLINE for #-} +for = flip traverse + +-- | 'forM' is 'mapM' with its arguments flipped. +forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) +{-# INLINE forM #-} +forM = flip mapM + +-- left-to-right state transformer +newtype StateL s a = StateL { runStateL :: s -> (s, a) } + +instance Functor (StateL s) where + fmap f (StateL k) = StateL $ \ s -> + let (s', v) = k s in (s', f v) + +instance Applicative (StateL s) where + pure x = StateL (\ s -> (s, x)) + StateL kf <*> StateL kv = StateL $ \ s -> + let (s', f) = kf s + (s'', v) = kv s' + in (s'', f v) + +-- |The 'mapAccumL' function behaves like a combination of 'fmap' +-- and 'foldl'; it applies a function to each element of a structure, +-- passing an accumulating parameter from left to right, and returning +-- a final value of this accumulator together with the new structure. +mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s + +-- right-to-left state transformer +newtype StateR s a = StateR { runStateR :: s -> (s, a) } + +instance Functor (StateR s) where + fmap f (StateR k) = StateR $ \ s -> + let (s', v) = k s in (s', f v) + +instance Applicative (StateR s) where + pure x = StateR (\ s -> (s, x)) + StateR kf <*> StateR kv = StateR $ \ s -> + let (s', v) = kv s + (s'', f) = kf s' + in (s'', f v) + +-- |The 'mapAccumR' function behaves like a combination of 'fmap' +-- and 'foldr'; it applies a function to each element of a structure, +-- passing an accumulating parameter from right to left, and returning +-- a final value of this accumulator together with the new structure. +mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s + +-- | This function may be used as a value for `fmap` in a `Functor` instance. +fmapDefault :: Traversable t => (a -> b) -> t a -> t b +fmapDefault f = getId . traverse (Id . f) + +-- | This function may be used as a value for `Data.Foldable.foldMap` +-- in a `Foldable` instance. +foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m +foldMapDefault f = getConst . traverse (Const . f) + +-- local instances + +newtype Id a = Id { getId :: a } + +instance Functor Id where + fmap f (Id x) = Id (f x) + +instance Applicative Id where + pure = Id + Id f <*> Id x = Id (f x) diff --git a/lib/base/src/Data/Tuple.hs b/lib/base/src/Data/Tuple.hs --- a/lib/base/src/Data/Tuple.hs +++ b/lib/base/src/Data/Tuple.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. ----------------------------------------------------------------------------- -- | @@ -21,6 +20,7 @@ , snd -- :: (a,b) -> a , curry -- :: ((a, b) -> c) -> a -> b -> c , uncurry -- :: (a -> b -> c) -> ((a, b) -> c) + , swap -- :: (a,b) -> (b,a) #ifdef __NHC__ , (,)(..) , (,,)(..) @@ -41,15 +41,19 @@ where #ifdef __GLASGOW_HASKELL__ -import GHC.Bool -import GHC.Classes -import GHC.Ordering --- XXX The standalone deriving clauses fail with --- The data constructors of `(,)' are not all in scope --- so you cannot derive an instance for it --- In the stand-alone deriving instance for `Eq (a, b)' --- if we don't import GHC.Tuple + +import GHC.Base +-- We need to depend on GHC.Base so that +-- a) so that we get GHC.Bool, GHC.Classes, GHC.Ordering + +-- b) so that GHC.Base.inline is available, which is used +-- when expanding instance declarations + import GHC.Tuple +-- We must import GHC.Tuple, to ensure sure that the +-- data constructors of `(,)' are in scope when we do +-- the standalone deriving instance for Eq (a,b) etc + #endif /* __GLASGOW_HASKELL__ */ #ifdef __NHC__ @@ -75,90 +79,11 @@ ) #endif -default () -- Double isn't available yet - #ifdef __GLASGOW_HASKELL__ --- XXX Why aren't these derived? -instance Eq () where - () == () = True - () /= () = False - -instance Ord () where - () <= () = True - () < () = False - () >= () = True - () > () = False - max () () = () - min () () = () - compare () () = EQ +import GHC.Unit () +#endif -#ifndef __HADDOCK__ -deriving instance (Eq a, Eq b) => Eq (a, b) -deriving instance (Ord a, Ord b) => Ord (a, b) -deriving instance (Eq a, Eq b, Eq c) => Eq (a, b, c) -deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c) -deriving instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) -deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) - => Eq (a, b, c, d, e, f) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) - => Ord (a, b, c, d, e, f) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) - => Eq (a, b, c, d, e, f, g) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) - => Ord (a, b, c, d, e, f, g) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h) - => Eq (a, b, c, d, e, f, g, h) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h) - => Ord (a, b, c, d, e, f, g, h) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i) - => Eq (a, b, c, d, e, f, g, h, i) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i) - => Ord (a, b, c, d, e, f, g, h, i) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j) - => Eq (a, b, c, d, e, f, g, h, i, j) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j) - => Ord (a, b, c, d, e, f, g, h, i, j) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k) - => Eq (a, b, c, d, e, f, g, h, i, j, k) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k) - => Ord (a, b, c, d, e, f, g, h, i, j, k) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -#endif /* !__HADDOCK__ */ -#endif /* __GLASGOW_HASKELL__ */ +default () -- Double isn't available yet -- --------------------------------------------------------------------------- -- Standard functions over tuples @@ -180,3 +105,7 @@ uncurry :: (a -> b -> c) -> ((a, b) -> c) uncurry f p = f (fst p) (snd p) #endif /* neither __HUGS__ nor __NHC__ */ + +-- | Swap the components of a pair. +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) diff --git a/lib/base/src/Data/Typeable.hs b/lib/base/src/Data/Typeable.hs --- a/lib/base/src/Data/Typeable.hs +++ b/lib/base/src/Data/Typeable.hs @@ -21,7 +21,7 @@ -- and one can in turn define a type-safe cast operation. To this end, -- an unsafe cast is guarded by a test for type (representation) -- equivalence. The module "Data.Dynamic" uses Typeable for an --- implementation of dynamics. The module "Data.Generics" uses Typeable +-- implementation of dynamics. The module "Data.Data" uses Typeable -- and type-safe cast (but not dynamics) to support the \"Scrap your -- boilerplate\" style of generic programming. -- @@ -81,7 +81,7 @@ ) where -import qualified Data.HashTable as HT +--import qualified Data.HashTable as HT import Data.Maybe import Data.Int import Data.Word @@ -95,12 +95,14 @@ import GHC.Err (undefined) import GHC.Num (Integer, fromInteger, (+)) import GHC.Real ( rem, Ratio ) -import GHC.IOBase (IORef,newIORef,unsafePerformIO) +import GHC.IORef (IORef,newIORef) +import GHC.IO (unsafePerformIO,block) -- These imports are so we can define Typeable instances -- It'd be better to give Typeable instances in the modules themselves -- but they all have to be compiled before Typeable -import GHC.IOBase ( IOArray, IO, MVar, Handle, block ) +import GHC.IOArray +import GHC.MVar import GHC.ST ( ST ) import GHC.STRef ( STRef ) import GHC.Ptr ( Ptr, FunPtr ) @@ -168,7 +170,8 @@ -- of keys has no meaning either. -- typeRepKey :: TypeRep -> IO Int -typeRepKey (TypeRep (Key i) _ _) = return i +typeRepKey _ = return 0 +--typeRepKey (TypeRep (Key i) _ _) = return i -- -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") @@ -300,6 +303,22 @@ -- ------------------------------------------------------------- +{- Note [Memoising typeOf] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +IMPORTANT: we don't want to recalculate the type-rep once per +call to the dummy argument. This is what went wrong in Trac #3245 +So we help GHC by manually keeping the 'rep' *outside* the value +lambda, thus + + typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep + typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + +Notice the crucial use of scoped type variables here! +-} + -- | The class 'Typeable' allows a concrete representation of a type to -- be calculated. class Typeable a where @@ -313,78 +332,148 @@ class Typeable1 t where typeOf1 :: t a -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) where argType :: t a -> a - argType = undefined + argType = undefined +#endif -- | Variant for binary type constructors class Typeable2 t where typeOf2 :: t a b -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep +typeOf1Default = \_ -> rep + where + rep = typeOf2 (undefined :: t a b) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) where argType :: t a b -> a - argType = undefined + argType = undefined +#endif -- | Variant for 3-ary type constructors class Typeable3 t where typeOf3 :: t a b c -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep +typeOf2Default = \_ -> rep + where + rep = typeOf3 (undefined :: t a b c) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) where argType :: t a b c -> a - argType = undefined + argType = undefined +#endif -- | Variant for 4-ary type constructors class Typeable4 t where typeOf4 :: t a b c d -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep +typeOf3Default = \_ -> rep + where + rep = typeOf4 (undefined :: t a b c d) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) where argType :: t a b c d -> a - argType = undefined - + argType = undefined +#endif + -- | Variant for 5-ary type constructors class Typeable5 t where typeOf5 :: t a b c d e -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep +typeOf4Default = \_ -> rep + where + rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e -> a - argType = undefined + argType = undefined +#endif -- | Variant for 6-ary type constructors class Typeable6 t where typeOf6 :: t a b c d e f -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep +typeOf5Default = \_ -> rep + where + rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e f -> a - argType = undefined + argType = undefined +#endif -- | Variant for 7-ary type constructors class Typeable7 t where typeOf7 :: t a b c d e f g -> TypeRep +#ifdef __GLASGOW_HASKELL__ -- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep +typeOf6Default = \_ -> rep + where + rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e f g -> a - argType = undefined + argType = undefined +#endif #ifdef __GLASGOW_HASKELL__ -- Given a @Typeable@/n/ instance for an /n/-ary type constructor, @@ -488,7 +577,7 @@ INSTANCE_TYPEABLE1(IO,ioTc,"IO") #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) --- Types defined in GHC.IOBase +-- Types defined in GHC.MVar INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) #endif @@ -538,7 +627,9 @@ #endif INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +#ifndef __GLASGOW_HASKELL__ INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") +#endif INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") @@ -564,9 +655,11 @@ --------------------------------------------- #ifndef __HUGS__ -newtype Key = Key Int deriving( Eq ) +--newtype Key = Key Int deriving( Eq ) +type Key = String #endif +{- data KeyPr = KeyPr !Key !Key deriving( Eq ) hashKP :: KeyPr -> Int32 @@ -590,7 +683,7 @@ let ret = Cache { next_key = key_loc, tc_tbl = empty_tc_tbl, ap_tbl = empty_ap_tbl } -#ifdef __GLASGOW_HASKELL__ && !defined(__LHC__) +#ifdef __GLASGOW_HASKELL__ block $ do stable_ref <- newStablePtr ret let ref = castStablePtrToPtr stable_ref @@ -618,8 +711,10 @@ foreign import ccall unsafe "genSymZh" genSym :: IO Int #endif - +-} mkTyConKey :: String -> Key +mkTyConKey key = key +{- mkTyConKey str = unsafePerformIO $ do let Cache {next_key = kloc, tc_tbl = tbl} = cache @@ -629,8 +724,10 @@ Nothing -> do { k <- newKey kloc ; HT.insert tbl str k ; return k } - +-} appKey :: Key -> Key -> Key +appKey k1 k2 = k1++k2 +{- appKey k1 k2 = unsafePerformIO $ do let Cache {next_key = kloc, ap_tbl = tbl} = cache @@ -642,6 +739,7 @@ return k } where kpr = KeyPr k1 k2 - +-} appKeys :: Key -> [Key] -> Key -appKeys k ks = foldl appKey k ks +appKeys k ks = k ++ foldr (++) [] ks +--appKeys k ks = foldl appKey k ks diff --git a/lib/base/src/Data/Typeable.hs-boot b/lib/base/src/Data/Typeable.hs-boot --- a/lib/base/src/Data/Typeable.hs-boot +++ b/lib/base/src/Data/Typeable.hs-boot @@ -5,14 +5,12 @@ import Data.Maybe import GHC.Base -import GHC.Show data TypeRep data TyCon mkTyCon :: String -> TyCon mkTyConApp :: TyCon -> [TypeRep] -> TypeRep -showsTypeRep :: TypeRep -> ShowS cast :: (Typeable a, Typeable b) => a -> Maybe b diff --git a/lib/base/src/Data/Unique.hs b/lib/base/src/Data/Unique.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Unique.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Unique +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- An abstract interface to a unique symbol generator. +-- +----------------------------------------------------------------------------- + +module Data.Unique ( + -- * Unique objects + Unique, -- instance (Eq, Ord) + newUnique, -- :: IO Unique + hashUnique -- :: Unique -> Int + ) where + +import Prelude + +import System.IO.Unsafe (unsafePerformIO) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Num +import GHC.Conc +import Data.Typeable +#endif + +-- | An abstract unique object. Objects of type 'Unique' may be +-- compared for equality and ordering and hashed into 'Int'. +newtype Unique = Unique Integer deriving (Eq,Ord +#ifdef __GLASGOW_HASKELL__ + ,Typeable +#endif + ) + +uniqSource :: TVar Integer +uniqSource = unsafePerformIO (newTVarIO 0) +{-# NOINLINE uniqSource #-} + +-- | Creates a new object of type 'Unique'. The value returned will +-- not compare equal to any other value of type 'Unique' returned by +-- previous calls to 'newUnique'. There is no limit on the number of +-- times 'newUnique' may be called. +newUnique :: IO Unique +newUnique = atomically $ do + val <- readTVar uniqSource + let next = val+1 + writeTVar uniqSource $! next + return (Unique next) + +-- SDM (18/3/2010): changed from MVar to STM. This fixes +-- 1. there was no async exception protection +-- 2. there was a space leak (now new value is strict) +-- 3. using atomicModifyIORef would be slightly quicker, but can +-- suffer from adverse scheduling issues (see #3838) +-- 4. also, the STM version is faster. + +-- | Hashes a 'Unique' into an 'Int'. Two 'Unique's may hash to the +-- same value, although in practice this is unlikely. The 'Int' +-- returned makes a good hash key. +hashUnique :: Unique -> Int +#if defined(__GLASGOW_HASKELL__) +hashUnique (Unique i) = I# (hashInteger i) +#else +hashUnique (Unique u) = fromInteger (u `mod` (toInteger (maxBound :: Int) + 1)) +#endif diff --git a/lib/base/src/Data/Version.hs b/lib/base/src/Data/Version.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Data/Version.hs @@ -0,0 +1,144 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Version +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (local universal quantification in ReadP) +-- +-- A general library for representation and manipulation of versions. +-- +-- Versioning schemes are many and varied, so the version +-- representation provided by this library is intended to be a +-- compromise between complete generality, where almost no common +-- functionality could reasonably be provided, and fixing a particular +-- versioning scheme, which would probably be too restrictive. +-- +-- So the approach taken here is to provide a representation which +-- subsumes many of the versioning schemes commonly in use, and we +-- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String' +-- which will be appropriate for some applications, but not all. +-- +----------------------------------------------------------------------------- + +module Data.Version ( + -- * The @Version@ type + Version(..), + -- * A concrete representation of @Version@ + showVersion, parseVersion, + ) where + +import Prelude -- necessary to get dependencies right + +-- These #ifdefs are necessary because this code might be compiled as +-- part of ghc/lib/compat, and hence might be compiled by an older version +-- of GHC. In which case, we might need to pick up ReadP from +-- Distribution.Compat.ReadP, because the version in +-- Text.ParserCombinators.ReadP doesn't have all the combinators we need. +#if __GLASGOW_HASKELL__ || __HUGS__ || __NHC__ +import Text.ParserCombinators.ReadP +#else +import Distribution.Compat.ReadP +#endif + +#if !__GLASGOW_HASKELL__ +import Data.Typeable ( Typeable, TyCon, mkTyCon, mkTyConApp ) +#else +import Data.Typeable ( Typeable ) +#endif + +import Data.List ( intersperse, sort ) +import Control.Monad ( liftM ) +import Data.Char ( isDigit, isAlphaNum ) + +{- | +A 'Version' represents the version of a software entity. + +An instance of 'Eq' is provided, which implements exact equality +modulo reordering of the tags in the 'versionTags' field. + +An instance of 'Ord' is also provided, which gives lexicographic +ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, +etc.). This is expected to be sufficient for many uses, but note that +you may need to use a more specific ordering for your versioning +scheme. For example, some versioning schemes may include pre-releases +which have tags @\"pre1\"@, @\"pre2\"@, and so on, and these would need to +be taken into account when determining ordering. In some cases, date +ordering may be more appropriate, so the application would have to +look for @date@ tags in the 'versionTags' field and compare those. +The bottom line is, don't always assume that 'compare' and other 'Ord' +operations are the right thing for every 'Version'. + +Similarly, concrete representations of versions may differ. One +possible concrete representation is provided (see 'showVersion' and +'parseVersion'), but depending on the application a different concrete +representation may be more appropriate. +-} +data Version = + Version { versionBranch :: [Int], + -- ^ The numeric branch for this version. This reflects the + -- fact that most software versions are tree-structured; there + -- is a main trunk which is tagged with versions at various + -- points (1,2,3...), and the first branch off the trunk after + -- version 3 is 3.1, the second branch off the trunk after + -- version 3 is 3.2, and so on. The tree can be branched + -- arbitrarily, just by adding more digits. + -- + -- We represent the branch as a list of 'Int', so + -- version 3.2.1 becomes [3,2,1]. Lexicographic ordering + -- (i.e. the default instance of 'Ord' for @[Int]@) gives + -- the natural ordering of branches. + + versionTags :: [String] -- really a bag + -- ^ A version can be tagged with an arbitrary list of strings. + -- The interpretation of the list of tags is entirely dependent + -- on the entity that this version applies to. + } + deriving (Read,Show +#if __GLASGOW_HASKELL__ + ,Typeable +#endif + ) + +#if !__GLASGOW_HASKELL__ +versionTc :: TyCon +versionTc = mkTyCon "Version" + +instance Typeable Version where + typeOf _ = mkTyConApp versionTc [] +#endif + +instance Eq Version where + v1 == v2 = versionBranch v1 == versionBranch v2 + && sort (versionTags v1) == sort (versionTags v2) + -- tags may be in any order + +instance Ord Version where + v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2 + +-- ----------------------------------------------------------------------------- +-- A concrete representation of 'Version' + +-- | Provides one possible concrete representation for 'Version'. For +-- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' +-- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@. +-- +showVersion :: Version -> String +showVersion (Version branch tags) + = concat (intersperse "." (map show branch)) ++ + concatMap ('-':) tags + +-- | A parser for versions in the format produced by 'showVersion'. +-- +#if __GLASGOW_HASKELL__ || __HUGS__ +parseVersion :: ReadP Version +#elif __NHC__ +parseVersion :: ReadPN r Version +#else +parseVersion :: ReadP r Version +#endif +parseVersion = do branch <- sepBy1 (liftM read $ munch1 isDigit) (char '.') + tags <- many (char '-' >> munch1 isAlphaNum) + return Version{versionBranch=branch, versionTags=tags} diff --git a/lib/base/src/Debug/Trace.hs b/lib/base/src/Debug/Trace.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Debug/Trace.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Debug.Trace +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'trace' function. +-- +----------------------------------------------------------------------------- + +module Debug.Trace ( + -- * Tracing + putTraceMsg, -- :: String -> IO () + trace, -- :: String -> a -> a + traceShow + ) where + +import Prelude +import System.IO.Unsafe + +#ifdef __GLASGOW_HASKELL__ +import Foreign.C.String +#else +import System.IO (hPutStrLn,stderr) +#endif + +-- | 'putTraceMsg' function outputs the trace message from IO monad. +-- Usually the output stream is 'System.IO.stderr' but if the function is called +-- from Windows GUI application then the output will be directed to the Windows +-- debug console. +putTraceMsg :: String -> IO () +putTraceMsg msg = do +#ifndef __GLASGOW_HASKELL__ + hPutStrLn stderr msg +#else + withCString "%s\n" $ \cfmt -> + withCString msg $ \cmsg -> + debugBelch cfmt cmsg + +-- don't use debugBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h debugBelch2" + debugBelch :: CString -> CString -> IO () +#endif + +{-# NOINLINE trace #-} +{-| +When called, 'trace' outputs the string in its first argument, before +returning the second argument as its result. The 'trace' function is not +referentially transparent, and should only be used for debugging, or for +monitoring execution. Some implementations of 'trace' may decorate the string +that\'s output to indicate that you\'re tracing. The function is implemented on +top of 'putTraceMsg'. +-} +trace :: String -> a -> a +trace string expr = unsafePerformIO $ do + putTraceMsg string + return expr + +{-| +Like 'trace', but uses 'show' on the argument to convert it to a 'String'. + +> traceShow = trace . show +-} +traceShow :: (Show a) => a -> b -> b +traceShow = trace . show diff --git a/lib/base/src/Foreign/C/Error.hsc b/lib/base/src/Foreign/C/Error.hsc --- a/lib/base/src/Foreign/C/Error.hsc +++ b/lib/base/src/Foreign/C/Error.hsc @@ -93,6 +93,11 @@ throwErrnoPathIfNull, throwErrnoPathIfMinus1, throwErrnoPathIfMinus1_, + + sEEK_CUR, + sEEK_SET, + sEEK_END, + ) where @@ -115,6 +120,9 @@ import GHC.IOBase import GHC.Num import GHC.Base +#if __LHC__ +import Foreign.Storable ( Storable(poke,peek) ) +#endif #elif __HUGS__ import Hugs.Prelude ( Handle, IOError, ioError ) import System.IO.Unsafe ( unsafePerformIO ) @@ -129,6 +137,18 @@ {-# CFILES cbits/PrelIOUtils.c #-} #endif +-- FIXME: These shouldn't be defined here. +sEEK_CUR :: CInt +sEEK_CUR = #{const SEEK_CUR} + +sEEK_SET :: CInt +sEEK_SET = #{const SEEK_SET} + +sEEK_END :: CInt +sEEK_END = #{const SEEK_END} + + + -- "errno" type -- ------------ @@ -290,7 +310,7 @@ -- We must call a C function to get the value of errno in general. On -- threaded systems, errno is hidden behind a C macro so that each OS -- thread gets its own copy. -#ifdef __NHC__ +#if defined(__NHC__) getErrno = do e <- peek _errno; return (Errno e) foreign import ccall unsafe "errno.h &errno" _errno :: Ptr CInt #else @@ -303,7 +323,7 @@ resetErrno :: IO () -- Again, setting errno has to be done via a C function. -#ifdef __NHC__ +#if defined(__NHC__) resetErrno = poke _errno 0 #else resetErrno = set_errno 0 @@ -503,8 +523,9 @@ errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do str <- strerror errno >>= peekCString #if __GLASGOW_HASKELL__ - return (IOError maybeHdl errType loc str maybeName) + return (IOError maybeHdl errType loc str (Just errno') maybeName) where + Errno errno' = errno errType | errno == eOK = OtherError | errno == e2BIG = ResourceExhausted diff --git a/lib/base/src/Foreign/C/String.hs b/lib/base/src/Foreign/C/String.hs --- a/lib/base/src/Foreign/C/String.hs +++ b/lib/base/src/Foreign/C/String.hs @@ -99,7 +99,6 @@ import GHC.List import GHC.Real import GHC.Num -import GHC.IOBase import GHC.Base #else import Data.Char ( chr, ord ) diff --git a/lib/base/src/Foreign/C/Types.hs b/lib/base/src/Foreign/C/Types.hs --- a/lib/base/src/Foreign/C/Types.hs +++ b/lib/base/src/Foreign/C/Types.hs @@ -8,12 +8,23 @@ import GHC.Real import GHC.Enum import Data.Bits -import {-# SOURCE #-} Foreign.Storable +import Foreign.Storable -newtype CInt = CInt Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) -newtype CSize = CSize Word64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) -newtype CChar = CChar Int8 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) -newtype CWchar = CWchar Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) -newtype CClock = CClock Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) -newtype CTime = CTime Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) -newtype CLong = CLong Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) +newtype CInt = CInt Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) +newtype CSize = CSize Word64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) +newtype CChar = CChar Int8 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) +newtype CWchar = CWchar Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) +newtype CClock = CClock Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) +newtype CTime = CTime Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) +newtype CLong = CLong Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits,Bounded) + +{-# RULES +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CInt (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CSize (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CChar (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CWchar (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CClock (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CTime (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CLong (fromInteger (smallInteger x)) + #-} + diff --git a/lib/base/src/Foreign/Concurrent.hs b/lib/base/src/Foreign/Concurrent.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/Foreign/Concurrent.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.Concurrent +-- Copyright : (c) The University of Glasgow 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires concurrency) +-- +-- FFI datatypes and operations that use or require concurrency (GHC only). +-- +----------------------------------------------------------------------------- + +module Foreign.Concurrent + ( + -- * Concurrency-based 'ForeignPtr' operations + + -- | These functions generalize their namesakes in the portable + -- "Foreign.ForeignPtr" module by allowing arbitrary 'IO' actions + -- as finalizers. These finalizers necessarily run in a separate + -- thread, cf. /Destructors, Finalizers and Synchronization/, + -- by Hans Boehm, /POPL/, 2003. + + newForeignPtr, + addForeignPtrFinalizer, + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.IO ( IO ) +import GHC.Ptr ( Ptr ) +import GHC.ForeignPtr ( ForeignPtr ) +import qualified GHC.ForeignPtr +#endif + +#ifdef __GLASGOW_HASKELL__ +newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) +-- ^Turns a plain memory reference into a foreign object by associating +-- a finalizer - given by the monadic operation - with the reference. +-- The finalizer will be executed after the last reference to the +-- foreign object is dropped. There is no guarantee of promptness, and +-- in fact there is no guarantee that the finalizer will eventually +-- run at all. +newForeignPtr = GHC.ForeignPtr.newConcForeignPtr + +addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO () +-- ^This function adds a finalizer to the given 'ForeignPtr'. +-- The finalizer will run after the last reference to the foreign object +-- is dropped, but /before/ all previously registered finalizers for the +-- same object. +addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer +#endif diff --git a/lib/base/src/Foreign/ForeignPtr.hs b/lib/base/src/Foreign/ForeignPtr.hs --- a/lib/base/src/Foreign/ForeignPtr.hs +++ b/lib/base/src/Foreign/ForeignPtr.hs @@ -78,7 +78,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +-- import GHC.IO import GHC.Num import GHC.Err ( undefined ) import GHC.ForeignPtr @@ -101,13 +101,10 @@ #ifndef __NHC__ newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a) -- ^Turns a plain memory reference into a foreign pointer, and --- associates a finaliser with the reference. The finaliser will be executed --- after the last reference to the foreign object is dropped. Note that there --- is no guarantee on how soon the finaliser is executed after the last --- reference was dropped; this depends on the details of the Haskell storage --- manager. Indeed, there is no guarantee that the finalizer is executed at --- all; a program may exit with finalizers outstanding. (This is true --- of GHC, other implementations may give stronger guarantees). +-- associates a finaliser with the reference. The finaliser will be +-- executed after the last reference to the foreign object is dropped. +-- There is no guarantee of promptness, however the finalizer will be +-- executed before the program exits. newForeignPtr finalizer p = do fObj <- newForeignPtr_ p addForeignPtrFinalizer finalizer fObj diff --git a/lib/base/src/Foreign/Marshal/Alloc.hs b/lib/base/src/Foreign/Marshal/Alloc.hs --- a/lib/base/src/Foreign/Marshal/Alloc.hs +++ b/lib/base/src/Foreign/Marshal/Alloc.hs @@ -40,7 +40,7 @@ #ifdef __GLASGOW_HASKELL__ import Foreign.ForeignPtr ( FinalizerPtr ) -import GHC.IOBase +import GHC.IO.Exception import GHC.Real import GHC.Ptr import GHC.Err @@ -70,6 +70,7 @@ -- The memory may be deallocated using 'free' or 'finalizerFree' when -- no longer required. -- +{-# INLINE malloc #-} malloc :: Storable a => IO (Ptr a) malloc = doMalloc undefined where @@ -93,6 +94,7 @@ -- The memory is freed when @f@ terminates (either normally or via an -- exception), so the pointer passed to @f@ must /not/ be used after this. -- +{-# INLINE alloca #-} alloca :: Storable a => (Ptr a -> IO b) -> IO b alloca = doAlloca undefined where @@ -192,7 +194,10 @@ failWhenNULL name f = do addr <- f if addr == nullPtr -#if __GLASGOW_HASKELL__ || __HUGS__ +#if __GLASGOW_HASKELL__ + then ioError (IOError Nothing ResourceExhausted name + "out of memory" Nothing Nothing) +#elif __HUGS__ then ioError (IOError Nothing ResourceExhausted name "out of memory" Nothing) #else diff --git a/lib/base/src/Foreign/Marshal/Array.hs b/lib/base/src/Foreign/Marshal/Array.hs --- a/lib/base/src/Foreign/Marshal/Array.hs +++ b/lib/base/src/Foreign/Marshal/Array.hs @@ -68,7 +68,6 @@ import Foreign.Marshal.Utils (copyBytes, moveBytes) #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase import GHC.Num import GHC.List import GHC.Err @@ -109,6 +108,9 @@ -- allocaArray0 :: Storable a => Int -> (Ptr a -> IO b) -> IO b allocaArray0 size = allocaArray (size + 1) +{-# INLINE allocaArray0 #-} + -- needed to get allocaArray to inline into withCString, for unknown + -- reasons --SDM 23/4/2010, see #4004 for benchmark -- |Adjust the size of an array -- diff --git a/lib/base/src/Foreign/Marshal/Error.hs b/lib/base/src/Foreign/Marshal/Error.hs --- a/lib/base/src/Foreign/Marshal/Error.hs +++ b/lib/base/src/Foreign/Marshal/Error.hs @@ -37,7 +37,8 @@ #endif import GHC.Base import GHC.Num -import GHC.IOBase +-- import GHC.IO +import GHC.IO.Exception #endif -- exported functions diff --git a/lib/base/src/Foreign/Marshal/Pool.hs b/lib/base/src/Foreign/Marshal/Pool.hs --- a/lib/base/src/Foreign/Marshal/Pool.hs +++ b/lib/base/src/Foreign/Marshal/Pool.hs @@ -48,8 +48,8 @@ import GHC.Base ( Int, Monad(..), (.), not ) import GHC.Err ( undefined ) import GHC.Exception ( throw ) -import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef, - block, unblock, catchAny ) +import GHC.IO ( IO, block, unblock, catchAny ) +import GHC.IORef ( IORef, newIORef, readIORef, writeIORef ) import GHC.List ( elem, length ) import GHC.Num ( Num(..) ) #else @@ -143,7 +143,7 @@ pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a) pooledReallocBytes (Pool pool) ptr size = do let cPtr = castPtr ptr - throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool) + _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool) newPtr <- reallocBytes cPtr size ptrs <- readIORef pool writeIORef pool (newPtr : delete cPtr ptrs) diff --git a/lib/base/src/Foreign/Marshal/Utils.hs b/lib/base/src/Foreign/Marshal/Utils.hs --- a/lib/base/src/Foreign/Marshal/Utils.hs +++ b/lib/base/src/Foreign/Marshal/Utils.hs @@ -53,7 +53,6 @@ import Foreign.Marshal.Alloc ( malloc, alloca ) #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase import GHC.Real ( fromIntegral ) import GHC.Num import GHC.Base @@ -159,14 +158,14 @@ -- first (destination); the copied areas may /not/ overlap -- copyBytes :: Ptr a -> Ptr a -> Int -> IO () -copyBytes dest src size = do memcpy dest src (fromIntegral size) +copyBytes dest src size = do _ <- memcpy dest src (fromIntegral size) return () -- |Copies the given number of bytes from the second area (source) into the -- first (destination); the copied areas /may/ overlap -- moveBytes :: Ptr a -> Ptr a -> Int -> IO () -moveBytes dest src size = do memmove dest src (fromIntegral size) +moveBytes dest src size = do _ <- memmove dest src (fromIntegral size) return () diff --git a/lib/base/src/Foreign/Ptr.hs b/lib/base/src/Foreign/Ptr.hs --- a/lib/base/src/Foreign/Ptr.hs +++ b/lib/base/src/Foreign/Ptr.hs @@ -50,7 +50,6 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Ptr -import GHC.IOBase import GHC.Base import GHC.Num import GHC.Read @@ -59,7 +58,7 @@ import GHC.Enum import GHC.Word ( Word(..) ) -import Data.Int +-- import Data.Int import Data.Word #else import Control.Monad ( liftM ) @@ -67,7 +66,7 @@ #endif import Data.Bits ---import Data.Typeable +import Data.Typeable import Foreign.Storable ( Storable(..) ) #ifdef __NHC__ @@ -101,7 +100,6 @@ #endif #ifndef __NHC__ -# include "CTypes.h" # ifdef __GLASGOW_HASKELL__ -- | An unsigned integral type that can be losslessly converted to and from diff --git a/lib/base/src/Foreign/Storable.hs b/lib/base/src/Foreign/Storable.hs --- a/lib/base/src/Foreign/Storable.hs +++ b/lib/base/src/Foreign/Storable.hs @@ -40,12 +40,12 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Storable import GHC.Stable ( StablePtr ) +import GHC.IO() -- Instance Monad IO import GHC.Num import GHC.Int import GHC.Word import GHC.Ptr import GHC.Err -import GHC.IOBase import GHC.Base #else import Data.Int @@ -185,6 +185,12 @@ #define SIZEOF_HSPTR WORD_SIZE #define ALIGNMENT_HSPTR WORD_SIZE +#define SIZEOF_HSFLOAT 4 +#define ALIGNMENT_HSFLOAT 4 + +#define SIZEOF_HSDOUBLE 8 +#define ALIGNMENT_HSDOUBLE 8 + #define SIZEOF_HSFUNPTR WORD_SIZE #define ALIGNMENT_HSFUNPTR WORD_SIZE @@ -212,6 +218,7 @@ #define SIZEOF_INT64 8 #define ALIGNMENT_INT64 8 + instance Storable Bool where sizeOf _ = sizeOf (undefined::HTYPE_INT) alignment _ = alignment (undefined::HTYPE_INT) @@ -249,13 +256,13 @@ {- STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR, readStablePtrOffPtr,writeStablePtrOffPtr) - +-} STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT, readFloatOffPtr,writeFloatOffPtr) STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE, readDoubleOffPtr,writeDoubleOffPtr) --} + STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8, readWord8OffPtr,writeWord8OffPtr) @@ -276,6 +283,7 @@ STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32, readInt32OffPtr,writeInt32OffPtr) + STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64, readInt64OffPtr,writeInt64OffPtr) diff --git a/lib/base/src/Foreign/Storable.hs-boot b/lib/base/src/Foreign/Storable.hs-boot deleted file mode 100644 --- a/lib/base/src/Foreign/Storable.hs-boot +++ /dev/null @@ -1,22 +0,0 @@ - -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module Foreign.Storable where - -import GHC.Base -import GHC.Int -import GHC.Word - -class Storable a - -instance Storable Int8 -instance Storable Int16 -instance Storable Int32 -instance Storable Int64 -instance Storable Word8 -instance Storable Word16 -instance Storable Word32 -instance Storable Word64 ---instance Storable Float ---instance Storable Double - diff --git a/lib/base/src/GHC/Arr.lhs b/lib/base/src/GHC/Arr.lhs --- a/lib/base/src/GHC/Arr.lhs +++ b/lib/base/src/GHC/Arr.lhs @@ -1,6 +1,7 @@ \begin{code} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE NoImplicitPrelude, NoBangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Arr @@ -15,6 +16,7 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.Arr where import GHC.Enum @@ -74,8 +76,14 @@ unsafeRangeSize :: (a,a) -> Int -- Must specify one of index, unsafeIndex + + -- 'index' is typically over-ridden in instances, with essentially + -- the same code, but using indexError instead of hopelessIndexError + -- Reason: we have 'Show' at the instances + {-# INLINE index #-} -- See Note [Inlining index] index b i | inRange b i = unsafeIndex b i - | otherwise = error "Error in array index" + | otherwise = hopelessIndexError + unsafeIndex b i = index b i rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 @@ -103,8 +111,54 @@ %* * %********************************************************* +Note [Inlining index] +~~~~~~~~~~~~~~~~~~~~~ +We inline the 'index' operation, + + * Partly because it generates much faster code + (although bigger); see Trac #1216 + + * Partly because it exposes the bounds checks to the simplifier which + might help a big. + +If you make a per-instance index method, you may consider inlining it. + +Note [Double bounds-checking of index values] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When you index an array, a!x, there are two possible bounds checks we might make: + + (A) Check that (inRange (bounds a) x) holds. + + (A) is checked in the method for 'index' + + (B) Check that (index (bounds a) x) lies in the range 0..n, + where n is the size of the underlying array + + (B) is checked in the top-level function (!), in safeIndex. + +Of course it *should* be the case that (A) holds iff (B) holds, but that +is a property of the particular instances of index, bounds, and inRange, +so GHC cannot guarantee it. + + * If you do (A) and not (B), then you might get a seg-fault, + by indexing at some bizarre location. Trac #1610 + + * If you do (B) but not (A), you may get no complaint when you index + an array out of its semantic bounds. Trac #2120 + +At various times we have had (A) and not (B), or (B) and not (A); both +led to complaints. So now we implement *both* checks (Trac #2669). + +For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this. + +Note [Out-of-bounds error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default method for 'index' generates hoplelessIndexError, because +Ix doesn't have Show as a superclass. For particular base types we +can do better, so we override the default method for index. + \begin{code} --- abstract these errors from the relevant index functions so that +-- Abstract these errors from the relevant index functions so that -- the guts of the function will be small enough to inline. {-# NOINLINE indexError #-} @@ -115,6 +169,9 @@ showString " out of range " $ showParen True (showsPrec 0 rng) "") +hopelessIndexError :: Int -- Try to use 'indexError' instead! +hopelessIndexError = error "Error in array index" + ---------------------------------------------------------------------- instance Ix Char where {-# INLINE range #-} @@ -123,6 +180,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (m,_n) i = fromEnum i - fromEnum m + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Char" @@ -138,6 +197,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (m,_n) i = i - m + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Int" @@ -152,6 +213,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (m,_n) i = fromInteger (i - m) + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Integer" @@ -165,6 +228,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (l,_) i = fromEnum i - fromEnum l + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Bool" @@ -178,6 +243,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (l,_) i = fromEnum i - fromEnum l + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Ordering" @@ -191,7 +258,8 @@ unsafeIndex ((), ()) () = 0 {-# INLINE inRange #-} inRange ((), ()) () = True - {-# INLINE index #-} + + {-# INLINE index #-} -- See Note [Inlining index] index b i = unsafeIndex b i ---------------------------------------------------------------------- @@ -332,7 +400,6 @@ arrEleBottom :: a arrEleBottom = error "(Array.!): undefined array element" -{-# INLINE array #-} -- | Construct an array with the specified bounds and containing values -- for given indices within these bounds. -- @@ -358,6 +425,7 @@ -- then the array is legal, but empty. Indexing an empty array always -- gives an array-bounds error, but 'bounds' still yields the bounds -- with which the array was constructed. +{-# INLINE array #-} array :: Ix i => (i,i) -- ^ a pair of /bounds/, each of the index type -- of the array. These bounds are the lowest and @@ -405,9 +473,9 @@ -- transformation on the list of elements; I guess it's impossible -- using mechanisms currently available. -{-# INLINE listArray #-} -- | Construct an array from a pair of bounds and a list of values in -- index order. +{-# INLINE listArray #-} listArray :: Ix i => (i,i) -> [e] -> Array i e listArray (l,u) es = runST (ST $ \s1# -> case safeRangeSize (l,u) of { n@(I# n#) -> @@ -420,57 +488,79 @@ case fillFromList 0# es s2# of { s3# -> done l u n marr# s3# }}}) -{-# INLINE (!) #-} -- | The value at the given index in an array. +{-# INLINE (!) #-} (!) :: Ix i => Array i e -> i -> e arr@(Array l u n _) ! i = unsafeAt arr $ safeIndex (l,u) n i {-# INLINE safeRangeSize #-} safeRangeSize :: Ix i => (i, i) -> Int safeRangeSize (l,u) = let r = rangeSize (l, u) - in if r < 0 then error "Negative range size" + in if r < 0 then negRange else r -{-# INLINE safeIndex #-} +-- Don't inline this error message everywhere!! +negRange :: Int -- Uninformative, but Ix does not provide Show +negRange = error "Negative range size" + +{-# INLINE[1] safeIndex #-} +-- See Note [Double bounds-checking of index values] +-- Inline *after* (!) so the rules can fire safeIndex :: Ix i => (i, i) -> Int -> i -> Int -safeIndex (l,u) n i = let i' = unsafeIndex (l,u) i +safeIndex (l,u) n i = let i' = index (l,u) i in if (0 <= i') && (i' < n) then i' - else error "Error in array index" + else badSafeIndex i' n +-- See Note [Double bounds-checking of index values] +{-# RULES +"safeIndex/I" safeIndex = lessSafeIndex :: (Int,Int) -> Int -> Int -> Int +"safeIndex/(I,I)" safeIndex = lessSafeIndex :: ((Int,Int),(Int,Int)) -> Int -> (Int,Int) -> Int +"safeIndex/(I,I,I)" safeIndex = lessSafeIndex :: ((Int,Int,Int),(Int,Int,Int)) -> Int -> (Int,Int,Int) -> Int + #-} + +lessSafeIndex :: Ix i => (i, i) -> Int -> i -> Int +-- See Note [Double bounds-checking of index values] +-- Do only (A), the semantic check +lessSafeIndex (l,u) _ i = index (l,u) i + +-- Don't inline this long error message everywhere!! +badSafeIndex :: Int -> Int -> Int +badSafeIndex i' n = error ("Error in array index; " ++ show i' ++ + " not in range [0.." ++ show n ++ ")") + {-# INLINE unsafeAt #-} unsafeAt :: Ix i => Array i e -> Int -> e unsafeAt (Array _ _ _ arr#) (I# i#) = case indexArray# arr# i# of (# e #) -> e -{-# INLINE bounds #-} -- | The bounds with which an array was constructed. +{-# INLINE bounds #-} bounds :: Ix i => Array i e -> (i,i) bounds (Array l u _ _) = (l,u) -{-# INLINE numElements #-} -- | The number of elements in the array. +{-# INLINE numElements #-} numElements :: Ix i => Array i e -> Int numElements (Array _ _ n _) = n -{-# INLINE indices #-} -- | The list of indices of an array in ascending order. +{-# INLINE indices #-} indices :: Ix i => Array i e -> [i] indices (Array l u _ _) = range (l,u) -{-# INLINE elems #-} -- | The list of elements of an array in index order. +{-# INLINE elems #-} elems :: Ix i => Array i e -> [e] elems arr@(Array _ _ n _) = [unsafeAt arr i | i <- [0 .. n - 1]] -{-# INLINE assocs #-} -- | The list of associations of an array in index order. +{-# INLINE assocs #-} assocs :: Ix i => Array i e -> [(i, e)] assocs arr@(Array l u _ _) = [(i, arr ! i) | i <- range (l,u)] -{-# INLINE accumArray #-} -- | The 'accumArray' deals with repeated indices in the association -- list using an /accumulating function/ which combines the values of -- associations with the same index. @@ -485,6 +575,7 @@ -- the values, as well as the indices, in the association list. Thus, -- unlike ordinary arrays built with 'array', accumulated arrays should -- not in general be recursive. +{-# INLINE accumArray #-} accumArray :: Ix i => (e -> a -> e) -- ^ accumulating function -> e -- ^ initial value @@ -514,7 +605,6 @@ case writeArray# marr# i# (f old new) s2# of s3# -> next s3# -{-# INLINE (//) #-} -- | Constructs an array identical to the first argument except that it has -- been updated by the associations in the right argument. -- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then @@ -526,6 +616,7 @@ -- Repeated indices in the association list are handled as for 'array': -- Haskell 98 specifies that the resulting array is undefined (i.e. bottom), -- but GHC's implementation uses the last association for each index. +{-# INLINE (//) #-} (//) :: Ix i => Array i e -> [(i, e)] -> Array i e arr@(Array l u n _) // ies = unsafeReplace arr [(safeIndex (l,u) n i, e) | (i, e) <- ies] @@ -536,13 +627,13 @@ STArray l u n marr# <- thawSTArray arr ST (foldr (fill marr#) (done l u n marr#) ies)) -{-# INLINE accum #-} -- | @'accum' f@ takes an array and an association list and accumulates -- pairs from the list into the array with the accumulating function @f@. -- Thus 'accumArray' can be defined using 'accum': -- -- > accumArray f z b = accum f (array b [(i, z) | i <- range b]) -- +{-# INLINE accum #-} accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e accum f arr@(Array l u n _) ies = unsafeAccum f arr [(safeIndex (l,u) n i, e) | (i, e) <- ies] @@ -558,13 +649,13 @@ amap f arr@(Array l u n _) = unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]] -{-# INLINE ixmap #-} -- | 'ixmap' allows for transformations on array indices. -- It may be thought of as providing function composition on the right -- with the mapping that the original array embodies. -- -- A similar transformation of array values may be achieved using 'fmap' -- from the 'Array' instance of the 'Functor' class. +{-# INLINE ixmap #-} ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e ixmap (l,u) f arr = array (l,u) [(i, arr ! f i) | i <- range (l,u)] diff --git a/lib/base/src/GHC/Base.lhs b/lib/base/src/GHC/Base.lhs --- a/lib/base/src/GHC/Base.lhs +++ b/lib/base/src/GHC/Base.lhs @@ -63,6 +63,8 @@ \begin{code} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +-- -fno-warn-orphans is needed for things like: +-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -79,8 +81,6 @@ -- ----------------------------------------------------------------------------- -#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#) - -- #hide module GHC.Base ( @@ -101,10 +101,19 @@ import GHC.Generics import GHC.Ordering import GHC.Prim +import {-# SOURCE #-} GHC.Show import {-# SOURCE #-} GHC.Err +import {-# SOURCE #-} GHC.IO (failIO) +-- These two are not strictly speaking required by this module, but they are +-- implicit dependencies whenever () or tuples are mentioned, so adding them +-- as imports here helps to get the dependencies right in the new build system. +import GHC.Tuple () +import GHC.Unit () + infixr 9 . infixr 5 ++ +infixl 4 <$ infixl 1 >>, >>= infixr 0 $ @@ -168,6 +177,12 @@ class Functor f where fmap :: (a -> b) -> f a -> f b + -- | Replace all locations in the input with the same value. + -- The default definition is @'fmap' . 'const'@, but this may be + -- overridden with a more efficient version. + (<$) :: a -> f b -> f a + (<$) = fmap . const + {- | The 'Monad' class defines the basic operations over a /monad/, a concept from a branch of mathematics known as /category theory/. From the perspective of a Haskell programmer, however, it is best to @@ -209,6 +224,7 @@ -- failure in a @do@ expression. fail :: String -> m a + {-# INLINE (>>) #-} m >> k = m >>= \_ -> k fail s = error s \end{code} @@ -221,24 +237,6 @@ %********************************************************* \begin{code} --- do explicitly: deriving (Eq, Ord) --- to avoid weird names like con2tag_[]# - -instance (Eq a) => Eq [a] where - {-# SPECIALISE instance Eq [Char] #-} - [] == [] = True - (x:xs) == (y:ys) = x == y && xs == ys - _xs == _ys = False - -instance (Ord a) => Ord [a] where - {-# SPECIALISE instance Ord [Char] #-} - compare [] [] = EQ - compare [] (_:_) = LT - compare (_:_) [] = GT - compare (x:xs) (y:ys) = case compare x y of - EQ -> compare xs ys - other -> other - instance Functor [] where fmap = map @@ -268,10 +266,12 @@ -- foldr f z (x:xs) = f x (foldr f z xs) {-# INLINE [0] foldr #-} -- Inline only in the final stage, after the foldr/cons rule has had a chance -foldr k z xs = go xs - where - go [] = z - go (y:ys) = y `k` go ys +-- Also note that we inline it when it has *two* parameters, which are the +-- ones we are keen about specialising! +foldr k z = go + where + go [] = z + go (y:ys) = y `k` go ys -- | A list producer that can be fused with 'foldr'. -- This function is merely @@ -359,7 +359,7 @@ -- Note eta expanded mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst {-# INLINE [0] mapFB #-} -mapFB c f x ys = c (f x) ys +mapFB c f = \x ys -> c (f x) ys -- The rules for map work like this. -- @@ -416,30 +416,6 @@ %********************************************************* \begin{code} --- |The 'Bool' type is an enumeration. It is defined with 'False' --- first so that the corresponding 'Prelude.Enum' instance will give --- 'Prelude.fromEnum' 'False' the value zero, and --- 'Prelude.fromEnum' 'True' the value 1. --- The actual definition is in the ghc-prim package. - --- XXX These don't work: --- deriving instance Eq Bool --- deriving instance Ord Bool --- : --- Illegal binding of built-in syntax: con2tag_Bool# - -instance Eq Bool where - True == True = True - False == False = True - _ == _ = False - -instance Ord Bool where - compare False True = LT - compare True False = GT - compare _ _ = EQ - --- Read is in GHC.Read, Show in GHC.Show - -- |'otherwise' is defined as the value 'True'. It helps to make -- guards more readable. eg. -- @@ -451,36 +427,6 @@ %********************************************************* %* * -\subsection{Type @Ordering@} -%* * -%********************************************************* - -\begin{code} --- | Represents an ordering relationship between two values: less --- than, equal to, or greater than. An 'Ordering' is returned by --- 'compare'. --- XXX These don't work: --- deriving instance Eq Ordering --- deriving instance Ord Ordering --- Illegal binding of built-in syntax: con2tag_Ordering# -instance Eq Ordering where - EQ == EQ = True - LT == LT = True - GT == GT = True - _ == _ = False - -- Read in GHC.Read, Show in GHC.Show - -instance Ord Ordering where - LT <= _ = True - _ <= LT = False - EQ <= _ = True - _ <= EQ = False - GT <= GT = True -\end{code} - - -%********************************************************* -%* * \subsection{Type @Char@ and @String@} %* * %********************************************************* @@ -504,20 +450,6 @@ 'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr'). -} --- We don't use deriving for Eq and Ord, because for Ord the derived --- instance defines only compare, which takes two primops. Then --- '>' uses compare, and therefore takes two primops instead of one. - -instance Eq Char where - (C# c1) == (C# c2) = c1 `eqChar#` c2 - (C# c1) /= (C# c2) = c1 `neChar#` c2 - -instance Ord Char where - (C# c1) > (C# c2) = c1 `gtChar#` c2 - (C# c1) >= (C# c2) = c1 `geChar#` c2 - (C# c1) <= (C# c2) = c1 `leChar#` c2 - (C# c1) < (C# c2) = c1 `ltChar#` c2 - {-# RULES "x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True "x# `neChar#` x#" forall x#. x# `neChar#` x# = False @@ -529,8 +461,10 @@ -- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'. chr :: Int -> Char -chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#) - | otherwise = error "Prelude.chr: bad argument" +chr i@(I# i#) + | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#) + | otherwise + = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") unsafeChr :: Int -> Char unsafeChr (I# i#) = C# (chr# i#) @@ -567,10 +501,13 @@ twoInt = I# 2# {- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -} -#if WORD_SIZE == 4 +#if WORD_SIZE_IN_BITS == 31 +minInt = I# (-0x40000000#) +maxInt = I# 0x3FFFFFFF# +#elif WORD_SIZE_IN_BITS == 32 minInt = I# (-0x80000000#) maxInt = I# 0x7FFFFFFF# -#else +#else minInt = I# (-0x8000000000000000#) maxInt = I# 0x7FFFFFFFFFFFFFFF# #endif @@ -619,16 +556,6 @@ -- sees it as lazy. Then the worker/wrapper phase inlines it. -- Result: happiness - --- | The call '(inline f)' reduces to 'f', but 'inline' has a BuiltInRule --- that tries to inline 'f' (if it has an unfolding) unconditionally --- The 'NOINLINE' pragma arranges that inline only gets inlined (and --- hence eliminated) late in compilation, after the rule has had --- a god chance to fire. -inline :: a -> a -{-# NOINLINE[0] inline #-} -inline x = x - -- Assertion function. This simply ignores its boolean argument. -- The compiler may rewrite it to @('assertError' line)@. @@ -664,8 +591,10 @@ -- | Function composition. {-# INLINE (.) #-} -(.) :: (b -> c) -> (a -> b) -> a -> c -(.) f g x = f (g x) +-- Make sure it has TWO args only on the left, so that it inlines +-- when applied to two functions, even if there is no final argument +(.) :: (b -> c) -> (a -> b) -> a -> c +(.) f g = \x -> f (g x) -- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@. flip :: (a -> b -> c) -> b -> a -> c @@ -698,6 +627,38 @@ %********************************************************* %* * +\subsection{@Functor@ and @Monad@ instances for @IO@} +%* * +%********************************************************* + +\begin{code} +instance Functor IO where + fmap f x = x >>= (return . f) + +instance Monad IO where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \ _ -> k + return = returnIO + (>>=) = bindIO + fail s = GHC.IO.failIO s + +returnIO :: a -> IO a +returnIO x = IO $ \ s -> (# s, x #) + +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s + +thenIO :: IO a -> IO b -> IO b +thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s + +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIO (IO a) = a +\end{code} + +%********************************************************* +%* * \subsection{@getTag@} %* * %********************************************************* @@ -744,7 +705,7 @@ (x# <# 0#) && (y# ># 0#) = if r# /=# 0# then r# +# y# else 0# | otherwise = r# where - r# = x# `remInt#` y# + !r# = x# `remInt#` y# \end{code} Definitions of the boxed PrimOps; these will be @@ -764,7 +725,7 @@ {-# INLINE remInt #-} {-# INLINE negateInt #-} -plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int +plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt :: Int -> Int -> Int (I# x) `plusInt` (I# y) = I# (x +# y) (I# x) `minusInt` (I# y) = I# (x -# y) (I# x) `timesInt` (I# y) = I# (x *# y) @@ -784,17 +745,6 @@ "1# *# x#" forall x#. 1# *# x# = x# #-} -gcdInt (I# a) (I# b) = g a b - where g 0# 0# = error "GHC.Base.gcdInt: gcd 0 0 is undefined" - g 0# _ = I# absB - g _ 0# = I# absA - g _ _ = I# (gcdInt# absA absB) - - absInt x = if x <# 0# then negateInt# x else x - - absA = absInt a - absB = absInt b - negateInt :: Int -> Int negateInt (I# x) = I# (negateInt# x) @@ -862,34 +812,34 @@ -- | Shift the argument left by the specified number of bits -- (which must be non-negative). shiftL# :: Word# -> Int# -> Word# -a `shiftL#` b | b >=# WORD_SIZE_IN_BITS_ = int2Word# 0# +a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# | otherwise = a `uncheckedShiftL#` b -- | Shift the argument right by the specified number of bits -- (which must be non-negative). shiftRL# :: Word# -> Int# -> Word# -a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS_ = int2Word# 0# +a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# | otherwise = a `uncheckedShiftRL#` b -- | Shift the argument left by the specified number of bits -- (which must be non-negative). iShiftL# :: Int# -> Int# -> Int# -a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS_ = 0# +a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0# | otherwise = a `uncheckedIShiftL#` b -- | Shift the argument right (signed) by the specified number of bits -- (which must be non-negative). iShiftRA# :: Int# -> Int# -> Int# -a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS_ = if a <# 0# then (-1#) else 0# +a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0# | otherwise = a `uncheckedIShiftRA#` b -- | Shift the argument right (unsigned) by the specified number of bits -- (which must be non-negative). iShiftRL# :: Int# -> Int# -> Int# -a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS_ = 0# +a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0# | otherwise = a `uncheckedIShiftRL#` b -#if WORD_SIZE == 4 +#if WORD_SIZE_IN_BITS == 32 {-# RULES "narrow32Int#" forall x#. narrow32Int# x# = x# "narrow32Word#" forall x#. narrow32Word# x# = x# @@ -914,7 +864,11 @@ \begin{code} unpackCString# :: Addr# -> [Char] -{-# NOINLINE [1] unpackCString# #-} +{-# NOINLINE unpackCString# #-} + -- There's really no point in inlining this, ever, cos + -- the loop doesn't specialise in an interesting + -- But it's pretty small, so there's a danger that + -- it'll be inlined at every literal, which is a waste unpackCString# addr = unpack 0# where @@ -922,9 +876,11 @@ | ch `eqChar#` '\0'# = [] | otherwise = C# ch : unpack (nh +# 1#) where - ch = indexCharOffAddr# addr nh + !ch = indexCharOffAddr# addr nh unpackAppendCString# :: Addr# -> [Char] -> [Char] +{-# NOINLINE unpackAppendCString# #-} + -- See the NOINLINE note on unpackCString# unpackAppendCString# addr rest = unpack 0# where @@ -932,15 +888,24 @@ | ch `eqChar#` '\0'# = rest | otherwise = C# ch : unpack (nh +# 1#) where - ch = indexCharOffAddr# addr nh + !ch = indexCharOffAddr# addr nh unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a -{-# NOINLINE [0] unpackFoldrCString# #-} --- Don't inline till right at the end; --- usually the unpack-list rule turns it into unpackCStringList + +-- Usually the unpack-list rule turns unpackFoldrCString# into unpackCString# + -- It also has a BuiltInRule in PrelRules.lhs: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) -- = unpackFoldrCString# "foobaz" c n + +{-# NOINLINE unpackFoldrCString# #-} +-- At one stage I had NOINLINE [0] on the grounds that, unlike +-- unpackCString#, there *is* some point in inlining +-- unpackFoldrCString#, because we get better code for the +-- higher-order function call. BUT there may be a lot of +-- literal strings, and making a separate 'unpack' loop for +-- each is highly gratuitous. See nofib/real/anna/PrettyPrint. + unpackFoldrCString# addr f z = unpack 0# where @@ -948,7 +913,7 @@ | ch `eqChar#` '\0'# = z | otherwise = C# ch `f` unpack (nh +# 1#) where - ch = indexCharOffAddr# addr nh + !ch = indexCharOffAddr# addr nh unpackCStringUtf8# :: Addr# -> [Char] unpackCStringUtf8# addr @@ -973,7 +938,7 @@ (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : unpack (nh +# 4#) where - ch = indexCharOffAddr# addr nh + !ch = indexCharOffAddr# addr nh unpackNBytes# :: Addr# -> Int# -> [Char] unpackNBytes# _addr 0# = [] @@ -986,7 +951,7 @@ ch -> unpack (C# ch : acc) (i# -# 1#) {-# RULES -"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) +"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) "unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a "unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n diff --git a/lib/base/src/GHC/Classes.hs b/lib/base/src/GHC/Classes.hs --- a/lib/base/src/GHC/Classes.hs +++ b/lib/base/src/GHC/Classes.hs @@ -1,3 +1,7 @@ + +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -16,7 +20,14 @@ module GHC.Classes where import GHC.Bool +import GHC.Integer +-- GHC.Magic is used in some derived instances +import GHC.Magic () import GHC.Ordering +import GHC.Prim +import GHC.Tuple +import GHC.Types +import GHC.Unit infix 4 ==, /=, <, <=, >=, > infixr 3 && @@ -34,9 +45,69 @@ class Eq a where (==), (/=) :: a -> a -> Bool + {-# INLINE (/=) #-} + {-# INLINE (==) #-} x /= y = not (x == y) x == y = not (x /= y) + +deriving instance Eq () +deriving instance (Eq a, Eq b) => Eq (a, b) +deriving instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +deriving instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) + => Eq (a, b, c, d, e, f) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) + => Eq (a, b, c, d, e, f, g) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h) + => Eq (a, b, c, d, e, f, g, h) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i) + => Eq (a, b, c, d, e, f, g, h, i) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j) + => Eq (a, b, c, d, e, f, g, h, i, j) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k) + => Eq (a, b, c, d, e, f, g, h, i, j, k) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +instance (Eq a) => Eq [a] where + {-# SPECIALISE instance Eq [Char] #-} + [] == [] = True + (x:xs) == (y:ys) = x == y && xs == ys + _xs == _ys = False + +deriving instance Eq Bool +deriving instance Eq Ordering + +instance Eq Char where + (C# c1) == (C# c2) = c1 `eqChar#` c2 + (C# c1) /= (C# c2) = c1 `neChar#` c2 + +instance Eq Integer where + (==) = eqInteger + (/=) = neqInteger + +instance Eq Float where + (F# x) == (F# y) = x `eqFloat#` y + +instance Eq Double where + (D# x) == (D# y) = x ==## y + -- | The 'Ord' class is used for totally ordered datatypes. -- -- Instances of 'Ord' can be derived for any user-defined @@ -69,6 +140,94 @@ -- because the latter is often more expensive max x y = if x <= y then y else x min x y = if x <= y then x else y + +-- This fails for some reason. +--deriving instance Ord () +instance Ord () where + compare () () = EQ +deriving instance (Ord a, Ord b) => Ord (a, b) +deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) + +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) + => Ord (a, b, c, d, e, f) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) + => Ord (a, b, c, d, e, f, g) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h) + => Ord (a, b, c, d, e, f, g, h) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i) + => Ord (a, b, c, d, e, f, g, h, i) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j) + => Ord (a, b, c, d, e, f, g, h, i, j) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k) + => Ord (a, b, c, d, e, f, g, h, i, j, k) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +instance (Ord a) => Ord [a] where + {-# SPECIALISE instance Ord [Char] #-} + compare [] [] = EQ + compare [] (_:_) = LT + compare (_:_) [] = GT + compare (x:xs) (y:ys) = case compare x y of + EQ -> compare xs ys + other -> other + +deriving instance Ord Bool +deriving instance Ord Ordering + +-- We don't use deriving for Ord Char, because for Ord the derived +-- instance defines only compare, which takes two primops. Then +-- '>' uses compare, and therefore takes two primops instead of one. +instance Ord Char where + (C# c1) > (C# c2) = c1 `gtChar#` c2 + (C# c1) >= (C# c2) = c1 `geChar#` c2 + (C# c1) <= (C# c2) = c1 `leChar#` c2 + (C# c1) < (C# c2) = c1 `ltChar#` c2 + +instance Ord Integer where + (<=) = leInteger + (>) = gtInteger + (<) = ltInteger + (>=) = geInteger + compare = compareInteger + +instance Ord Float where + (F# x) `compare` (F# y) + = if x `ltFloat#` y then LT + else if x `eqFloat#` y then EQ + else GT + + (F# x) < (F# y) = x `ltFloat#` y + (F# x) <= (F# y) = x `leFloat#` y + (F# x) >= (F# y) = x `geFloat#` y + (F# x) > (F# y) = x `gtFloat#` y + +instance Ord Double where + (D# x) `compare` (D# y) + = if x <## y then LT + else if x ==## y then EQ + else GT + + (D# x) < (D# y) = x <## y + (D# x) <= (D# y) = x <=## y + (D# x) >= (D# y) = x >=## y + (D# x) > (D# y) = x >## y -- OK, so they're technically not part of a class...: diff --git a/lib/base/src/GHC/Conc.lhs b/lib/base/src/GHC/Conc.lhs --- a/lib/base/src/GHC/Conc.lhs +++ b/lib/base/src/GHC/Conc.lhs @@ -37,6 +37,7 @@ , throwTo -- :: ThreadId -> Exception -> IO () , par -- :: a -> b -> b , pseq -- :: a -> b -> b + , runSparks , yield -- :: IO () , labelThread -- :: ThreadId -> String -> IO () @@ -49,17 +50,6 @@ , threadWaitRead -- :: Int -> IO () , threadWaitWrite -- :: Int -> IO () - -- * MVars - , MVar(..) - , newMVar -- :: a -> IO (MVar a) - , newEmptyMVar -- :: IO (MVar a) - , takeMVar -- :: MVar a -> IO a - , putMVar -- :: MVar a -> a -> IO () - , tryTakeMVar -- :: MVar a -> IO (Maybe a) - , tryPutMVar -- :: MVar a -> a -> IO Bool - , isEmptyMVar -- :: MVar a -> IO Bool - , addMVarFinalizer -- :: MVar a -> IO () -> IO () - -- * TVars , STM(..) , atomically -- :: STM a -> IO a @@ -72,10 +62,12 @@ , newTVar -- :: a -> STM (TVar a) , newTVarIO -- :: a -> STM (TVar a) , readTVar -- :: TVar a -> STM a + , readTVarIO -- :: TVar a -> IO a , writeTVar -- :: a -> TVar a -> STM () , unsafeIOToSTM -- :: IO a -> STM a -- * Miscellaneous + , withMVar #ifdef mingw32_HOST_OS , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) @@ -112,35 +104,43 @@ import Foreign import Foreign.C +#ifdef mingw32_HOST_OS +import Data.Typeable +#endif + #ifndef mingw32_HOST_OS import Data.Dynamic -import Control.Monad #endif +import Control.Monad import Data.Maybe import GHC.Base -import {-# SOURCE #-} GHC.Handle -import GHC.IOBase +#ifndef mingw32_HOST_OS +import GHC.Debug +#endif +import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) +import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import GHC.IO +import GHC.IO.Exception +import GHC.Exception +import GHC.IORef +import GHC.MVar import GHC.Num ( Num(..) ) import GHC.Real ( fromIntegral ) #ifndef mingw32_HOST_OS +import GHC.IOArray import GHC.Arr ( inRange ) #endif #ifdef mingw32_HOST_OS import GHC.Real ( div ) -import GHC.Ptr ( plusPtr, FunPtr(..) ) +import GHC.Ptr #endif #ifdef mingw32_HOST_OS import GHC.Read ( Read ) import GHC.Enum ( Enum ) #endif -import GHC.Exception ( SomeException(..), ErrorCall(..), throw ) import GHC.Pack ( packCString# ) -import GHC.Ptr ( Ptr(..) ) -import GHC.STRef import GHC.Show ( Show(..), showString ) -import Data.Typeable -import GHC.Err infixr 0 `par`, `pseq` \end{code} @@ -215,7 +215,7 @@ (see 'Control.Exception.block'). The newly created thread has an exception handler that discards the -exceptions 'BlockedOnDeadMVar', 'BlockedIndefinitely', and +exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and 'ThreadKilled', and passes all other exceptions to the uncaught exception handler (see 'setUncaughtExceptionHandler'). -} @@ -253,8 +253,11 @@ n <- peek n_capabilities return (fromIntegral n) +#if defined(mingw32_HOST_OS) && defined(__PIC__) +foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt +#else foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt - +#endif childHandler :: SomeException -> IO () childHandler err = catchException (real_handler err) childHandler @@ -262,9 +265,9 @@ real_handler se@(SomeException ex) = -- ignore thread GC and killThread exceptions: case cast ex of - Just BlockedOnDeadMVar -> return () + Just BlockedIndefinitelyOnMVar -> return () _ -> case cast ex of - Just BlockedIndefinitely -> return () + Just BlockedIndefinitelyOnSTM -> return () _ -> case cast ex of Just ThreadKilled -> return () _ -> case cast ex of @@ -272,16 +275,11 @@ Just StackOverflow -> reportStackOverflow _ -> reportError se -{- | 'killThread' terminates the given thread (GHC only). -Any work already done by the thread isn\'t -lost: the computation is suspended until required by another thread. -The memory used by the thread will be garbage collected if it isn\'t -referenced from anywhere. The 'killThread' function is defined in -terms of 'throwTo': +{- | 'killThread' raises the 'ThreadKilled' exception in the given +thread (GHC only). > killThread tid = throwTo tid ThreadKilled -Killthread is a no-op if the target thread has already completed. -} killThread :: ThreadId -> IO () killThread tid = throwTo tid ThreadKilled @@ -296,6 +294,10 @@ can kill each other, it is guaranteed that only one of the threads will get to kill the other. +Whatever work the target thread was doing when the exception was +raised is not lost: the computation is suspended until required by +another thread. + If the target thread is currently making a foreign call, then the exception will not be raised (and hence 'throwTo' will not return) until the call has completed. This is the case regardless of whether @@ -310,12 +312,17 @@ Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of the paper). -There is currently no guarantee that the exception delivered by 'throwTo' will be -delivered at the first possible opportunity. In particular, a thread may -unblock and then re-block exceptions (using 'unblock' and 'block') without receiving -a pending 'throwTo'. This is arguably undesirable behaviour. +There is no guarantee that the exception will be delivered promptly, +although the runtime will endeavour to ensure that arbitrary +delays don't occur. In GHC, an exception can only be raised when a +thread reaches a /safe point/, where a safe point is where memory +allocation occurs. Some loops do not perform any memory allocation +inside the loop and therefore cannot be interrupted by a 'throwTo'. - -} +Blocked 'throwTo' is fair: if multiple threads are trying to throw an +exception to the same target thread, they will succeed in FIFO order. + + -} throwTo :: Exception e => ThreadId -> e -> IO () throwTo (ThreadId tid) ex = IO $ \ s -> case (killThread# tid (toException ex) s) of s1 -> (# s1, () #) @@ -346,8 +353,8 @@ labelThread :: ThreadId -> String -> IO () labelThread (ThreadId t) str = IO $ \ s -> - let ps = packCString# str - adr = byteArrayContents# ps in + let !ps = packCString# str + !adr = byteArrayContents# ps in case (labelThread# t adr s) of s1 -> (# s1, () #) -- Nota Bene: 'pseq' used to be 'seq' @@ -369,6 +376,13 @@ par :: a -> b -> b par x y = case (par# x) of { _ -> lazy y } +-- | Internal function used by the RTS to run sparks. +runSparks :: IO () +runSparks = IO loop + where loop s = case getSpark# s of + (# s', n, p #) -> + if n ==# 0# then (# s', () #) + else p `seq` loop s' data BlockReason = BlockedOnMVar @@ -532,7 +546,7 @@ -- of those points then the transaction violating it is aborted -- and the exception raised by the invariant is propagated. alwaysSucceeds :: STM a -> STM () -alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () ) +alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) checkInv i -- | always is a variant of alwaysSucceeds in which the invariant is @@ -565,6 +579,16 @@ case newTVar# val s1# of (# s2#, tvar# #) -> (# s2#, TVar tvar# #) +-- |Return the current value stored in a TVar. +-- This is equivalent to +-- +-- > readTVarIO = atomically . readTVar +-- +-- but works much faster, because it doesn't perform a complete +-- transaction, it just reads the current value of the 'TVar'. +readTVarIO :: TVar a -> IO a +readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s# + -- |Return the current value stored in a TVar readTVar :: TVar a -> STM a readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s# @@ -577,111 +601,28 @@ \end{code} -%************************************************************************ -%* * -\subsection[mvars]{M-Structures} -%* * -%************************************************************************ - -M-Vars are rendezvous points for concurrent threads. They begin -empty, and any attempt to read an empty M-Var blocks. When an M-Var -is written, a single blocked thread may be freed. Reading an M-Var -toggles its state from full back to empty. Therefore, any value -written to an M-Var may only be read once. Multiple reads and writes -are allowed, but there must be at least one read between any two -writes. +MVar utilities \begin{code} ---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) - --- |Create an 'MVar' which is initially empty. -newEmptyMVar :: IO (MVar a) -newEmptyMVar = IO $ \ s# -> - case newMVar# s# of - (# s2#, svar# #) -> (# s2#, MVar svar# #) - --- |Create an 'MVar' which contains the supplied value. -newMVar :: a -> IO (MVar a) -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - --- |Return the contents of the 'MVar'. If the 'MVar' is currently --- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', --- the 'MVar' is left empty. --- --- There are two further important properties of 'takeMVar': --- --- * 'takeMVar' is single-wakeup. That is, if there are multiple --- threads blocked in 'takeMVar', and the 'MVar' becomes full, --- only one thread will be woken up. The runtime guarantees that --- the woken thread completes its 'takeMVar' operation. --- --- * When multiple threads are blocked on an 'MVar', they are --- woken up in FIFO order. This is useful for providing --- fairness properties of abstractions built using 'MVar's. --- -takeMVar :: MVar a -> IO a -takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# - --- |Put a value into an 'MVar'. If the 'MVar' is currently full, --- 'putMVar' will wait until it becomes empty. --- --- There are two further important properties of 'putMVar': --- --- * 'putMVar' is single-wakeup. That is, if there are multiple --- threads blocked in 'putMVar', and the 'MVar' becomes empty, --- only one thread will be woken up. The runtime guarantees that --- the woken thread completes its 'putMVar' operation. --- --- * When multiple threads are blocked on an 'MVar', they are --- woken up in FIFO order. This is useful for providing --- fairness properties of abstractions built using 'MVar's. --- -putMVar :: MVar a -> a -> IO () -putMVar (MVar mvar#) x = IO $ \ s# -> - case putMVar# mvar# x s# of - s2# -> (# s2#, () #) - --- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', --- the 'MVar' is left empty. -tryTakeMVar :: MVar a -> IO (Maybe a) -tryTakeMVar (MVar m) = IO $ \ s -> - case tryTakeMVar# m s of - (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty - (# s', _, a #) -> (# s', Just a #) -- MVar is full - --- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function --- attempts to put the value @a@ into the 'MVar', returning 'True' if --- it was successful, or 'False' otherwise. -tryPutMVar :: MVar a -> a -> IO Bool -tryPutMVar (MVar mvar#) x = IO $ \ s# -> - case tryPutMVar# mvar# x s# of - (# s, 0# #) -> (# s, False #) - (# s, _ #) -> (# s, True #) - --- |Check whether a given 'MVar' is empty. --- --- Notice that the boolean value returned is just a snapshot of --- the state of the MVar. By the time you get to react on its result, --- the MVar may have been filled (or emptied) - so be extremely --- careful when using this operation. Use 'tryTakeMVar' instead if possible. -isEmptyMVar :: MVar a -> IO Bool -isEmptyMVar (MVar mv#) = IO $ \ s# -> - case isEmptyMVar# mv# s# of - (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) +withMVar :: MVar a -> (a -> IO b) -> IO b +withMVar m io = + block $ do + a <- takeMVar m + b <- catchAny (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a + return b --- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and --- "System.Mem.Weak" for more about finalizers. -addMVarFinalizer :: MVar a -> IO () -> IO () -addMVarFinalizer (MVar m) finalizer = - IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } +modifyMVar_ :: MVar a -> (a -> IO a) -> IO () +modifyMVar_ m io = + block $ do + a <- takeMVar m + a' <- catchAny (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a' + return () \end{code} - %************************************************************************ %* * \subsection{Thread waiting} @@ -732,6 +673,7 @@ -- | Block the current thread until data is available to read on the -- given file descriptor (GHC only). threadWaitRead :: Fd -> IO () +threadWaitRead _ = return (){- threadWaitRead fd #ifndef mingw32_HOST_OS | threaded = waitForReadEvent fd @@ -740,10 +682,11 @@ case fromIntegral fd of { I# fd# -> case waitRead# fd# s of { s' -> (# s', () #) }} - +-} -- | Block the current thread until data can be written to the -- given file descriptor (GHC only). threadWaitWrite :: Fd -> IO () +threadWaitWrite _ = return () {- threadWaitWrite fd #ifndef mingw32_HOST_OS | threaded = waitForWriteEvent fd @@ -752,6 +695,7 @@ case fromIntegral fd of { I# fd# -> case waitWrite# fd# s of { s' -> (# s', () #) }} +-} -- | Suspends the current thread for a given number of microseconds -- (GHC only). @@ -817,23 +761,6 @@ -- around the scheduler loop. Furthermore, the scheduler can be simplified -- by not having to check for completed IO requests. --- Issues, possible problems: --- --- - we might want bound threads to just do the blocking --- operation rather than communicating with the IO manager --- thread. This would prevent simgle-threaded programs which do --- IO from requiring multiple OS threads. However, it would also --- prevent bound threads waiting on IO from being killed or sent --- exceptions. --- --- - Apprently exec() doesn't work on Linux in a multithreaded program. --- I couldn't repeat this. --- --- - How do we handle signal delivery in the multithreaded RTS? --- --- - forkProcess will kill the IO manager thread. Let's just --- hope we don't need to do any blocking IO between fork & exec. - #ifndef mingw32_HOST_OS data IOReq = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ()) @@ -845,25 +772,52 @@ | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) #ifndef mingw32_HOST_OS +{-# NOINLINE pendingEvents #-} pendingEvents :: IORef [IOReq] +pendingEvents = unsafePerformIO $ do + m <- newIORef [] + sharedCAF m getOrSetGHCConcPendingEventsStore + +foreign import ccall unsafe "getOrSetGHCConcPendingEventsStore" + getOrSetGHCConcPendingEventsStore :: Ptr a -> IO (Ptr a) #endif -pendingDelays :: IORef [DelayReq] - -- could use a strict list or array here -{-# NOINLINE pendingEvents #-} + {-# NOINLINE pendingDelays #-} -(pendingEvents,pendingDelays) = unsafePerformIO $ do - startIOManagerThread - reqs <- newIORef [] - dels <- newIORef [] - return (reqs, dels) - -- the first time we schedule an IO request, the service thread - -- will be created (cool, huh?) +pendingDelays :: IORef [DelayReq] +pendingDelays = unsafePerformIO $ do + m <- newIORef [] + sharedCAF m getOrSetGHCConcPendingDelaysStore +foreign import ccall unsafe "getOrSetGHCConcPendingDelaysStore" + getOrSetGHCConcPendingDelaysStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE ioManagerThread #-} +ioManagerThread :: MVar (Maybe ThreadId) +ioManagerThread = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetGHCConcIOManagerThreadStore + +foreign import ccall unsafe "getOrSetGHCConcIOManagerThreadStore" + getOrSetGHCConcIOManagerThreadStore :: Ptr a -> IO (Ptr a) + ensureIOManagerIsRunning :: IO () ensureIOManagerIsRunning - | threaded = seq pendingEvents $ return () + | threaded = startIOManagerThread | otherwise = return () +startIOManagerThread :: IO () +startIOManagerThread = do + modifyMVar_ ioManagerThread $ \old -> do + let create = do t <- forkIO ioManager; return (Just t) + case old of + Nothing -> create + Just t -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> create + _other -> return (Just t) + insertDelay :: DelayReq -> [DelayReq] -> [DelayReq] insertDelay d [] = [d] insertDelay d1 ds@(d2 : rest) @@ -876,31 +830,52 @@ type USecs = Word64 --- XXX: move into GHC.IOBase from Data.IORef? -atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s - foreign import ccall unsafe "getUSecOfDay" getUSecOfDay :: IO USecs -prodding :: IORef Bool {-# NOINLINE prodding #-} -prodding = unsafePerformIO (newIORef False) +prodding :: IORef Bool +prodding = unsafePerformIO $ do + r <- newIORef False + sharedCAF r getOrSetGHCConcProddingStore +foreign import ccall unsafe "getOrSetGHCConcProddingStore" + getOrSetGHCConcProddingStore :: Ptr a -> IO (Ptr a) + prodServiceThread :: IO () prodServiceThread = do - was_set <- atomicModifyIORef prodding (\a -> (True,a)) - if (not (was_set)) then wakeupIOManager else return () + -- NB. use atomicModifyIORef here, otherwise there are race + -- conditions in which prodding is left at True but the server is + -- blocked in select(). + was_set <- atomicModifyIORef prodding $ \b -> (True,b) + unless was_set wakeupIOManager +-- Machinery needed to ensure that we only have one copy of certain +-- CAFs in this module even when the base package is present twice, as +-- it is when base is dynamically loaded into GHCi. The RTS keeps +-- track of the single true value of the CAF, so even when the CAFs in +-- the dynamically-loaded base package are reverted, nothing bad +-- happens. +-- +sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a +sharedCAF a get_or_set = + block $ do + stable_ref <- newStablePtr a + let ref = castPtr (castStablePtrToPtr stable_ref) + ref2 <- get_or_set ref + if ref==ref2 + then return a + else do freeStablePtr stable_ref + deRefStablePtr (castPtrToStablePtr (castPtr ref2)) + #ifdef mingw32_HOST_OS -- ---------------------------------------------------------------------------- -- Windows IO manager thread -startIOManagerThread :: IO () -startIOManagerThread = do +ioManager :: IO () +ioManager = do wakeup <- c_getIOManagerEvent - forkIO $ service_loop wakeup [] - return () + service_loop wakeup [] service_loop :: HANDLE -- read end of pipe -> [DelayReq] -- current delay requests @@ -925,9 +900,7 @@ _ | r2 == io_MANAGER_DIE -> return True 0 -> return False -- spurious wakeup _ -> do start_console_handler (r2 `shiftR` 1); return False - if exit - then return () - else service_cont wakeup delays' + unless exit $ service_cont wakeup delays' _other -> service_cont wakeup delays' -- probably timeout @@ -955,7 +928,7 @@ start_console_handler r = case toWin32ConsoleEvent r of Just x -> withMVar win32ConsoleHandler $ \handler -> do - forkIO (handler x) + _ <- forkIO (handler x) return () Nothing -> return () @@ -972,15 +945,8 @@ win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler")) --- XXX Is this actually needed? -stick :: IORef HANDLE -{-# NOINLINE stick #-} -stick = unsafePerformIO (newIORef nullPtr) - wakeupIOManager :: IO () -wakeupIOManager = do - _hdl <- readIORef stick - c_sendIOManagerEvent io_MANAGER_WAKEUP +wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP -- Walk the queue of pending delays, waking up any that have passed -- and return the smallest delay to wait for. The queue of pending @@ -1029,23 +995,21 @@ -- ---------------------------------------------------------------------------- -- Unix IO manager thread, using select() -startIOManagerThread :: IO () -startIOManagerThread = do +ioManager :: IO () +ioManager = do allocaArray 2 $ \fds -> do - throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds) + throwErrnoIfMinus1_ "startIOManagerThread" (c_pipe fds) rd_end <- peekElemOff fds 0 wr_end <- peekElemOff fds 1 - setNonBlockingFD wr_end -- writes happen in a signal handler, we - -- don't want them to block. + setNonBlockingFD wr_end True -- writes happen in a signal handler, we + -- don't want them to block. setCloseOnExec rd_end setCloseOnExec wr_end - writeIORef stick (fromIntegral wr_end) c_setIOManagerPipe wr_end - forkIO $ do - allocaBytes sizeofFdSet $ \readfds -> do - allocaBytes sizeofFdSet $ \writefds -> do - allocaBytes sizeofTimeVal $ \timeval -> do - service_loop (fromIntegral rd_end) readfds writefds timeval [] [] + allocaBytes sizeofFdSet $ \readfds -> do + allocaBytes sizeofFdSet $ \writefds -> do + allocaBytes sizeofTimeVal $ \timeval -> do + service_loop (fromIntegral rd_end) readfds writefds timeval [] [] return () service_loop @@ -1058,6 +1022,17 @@ -> IO () service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do + -- reset prodding before we look at the new requests. If a new + -- client arrives after this point they will send a wakup which will + -- cause the server to loop around again, so we can be sure to not + -- miss any requests. + -- + -- NB. it's important to do this in the *first* iteration of + -- service_loop, rather than after calling select(), since a client + -- may have set prodding to True without sending a wakeup byte down + -- the pipe, because the pipe wasn't set up. + atomicModifyIORef prodding (\_ -> (False, ())) + -- pick up new IO requests new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a)) let reqs = new_reqs ++ old_reqs @@ -1106,7 +1081,8 @@ if b == 0 then return False else alloca $ \p -> do - c_read (fromIntegral wakeup) p 1 + warnErrnoIfMinus1_ "service_loop" $ + c_read (fromIntegral wakeup) p 1 s <- peek p case s of _ | s == io_MANAGER_WAKEUP -> return False @@ -1125,25 +1101,18 @@ runHandlers' fp (fromIntegral s) return False - if exit then return () else do - - atomicModifyIORef prodding (\_ -> (False,False)) + unless exit $ do reqs' <- if wakeup_all then do wakeupAll reqs; return [] else completeRequests reqs readfds writefds [] service_loop wakeup readfds writefds ptimeval reqs' delays' -io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: CChar +io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: Word8 io_MANAGER_WAKEUP = 0xff io_MANAGER_DIE = 0xfe io_MANAGER_SYNC = 0xfd --- | the stick is for poking the IO manager with -stick :: IORef Fd -{-# NOINLINE stick #-} -stick = unsafePerformIO (newIORef 0) - {-# NOINLINE sync #-} sync :: IORef [MVar ()] sync = unsafePerformIO (newIORef []) @@ -1153,16 +1122,11 @@ syncIOManager = do m <- newEmptyMVar atomicModifyIORef sync (\old -> (m:old,())) - fd <- readIORef stick - with io_MANAGER_SYNC $ \pbuf -> do - c_write (fromIntegral fd) pbuf 1; return () + c_ioManagerSync takeMVar m -wakeupIOManager :: IO () -wakeupIOManager = do - fd <- readIORef stick - with io_MANAGER_WAKEUP $ \pbuf -> do - c_write (fromIntegral fd) pbuf 1; return () +foreign import ccall unsafe "ioManagerSync" c_ioManagerSync :: IO () +foreign import ccall unsafe "ioManagerWakeup" wakeupIOManager :: IO () -- For the non-threaded RTS runHandlers :: Ptr Word8 -> Int -> IO () @@ -1182,8 +1146,20 @@ else do handler <- unsafeReadIOArray arr int case handler of Nothing -> return () - Just (f,_) -> do forkIO (f p_info); return () + Just (f,_) -> do _ <- forkIO (f p_info) + return () +warnErrnoIfMinus1_ :: Num a => String -> IO a -> IO () +warnErrnoIfMinus1_ what io + = do r <- io + when (r == -1) $ do + errno <- getErrno + str <- strerror errno >>= peekCString + when (r == -1) $ + debugErrLn ("Warning: " ++ what ++ " failed: " ++ str) + +foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar) + foreign import ccall "setIOManagerPipe" c_setIOManagerPipe :: CInt -> IO () @@ -1203,8 +1179,12 @@ signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic))) signal_handlers = unsafePerformIO $ do arr <- newIOArray (0,maxSig) Nothing - newMVar arr + m <- newMVar arr + sharedCAF m getOrSetGHCConcSignalHandlerStore +foreign import ccall unsafe "getOrSetGHCConcSignalHandlerStore" + getOrSetGHCConcSignalHandlerStore :: Ptr a -> IO (Ptr a) + setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic)) setHandler sig handler = do let int = fromIntegral sig @@ -1305,7 +1285,7 @@ data CFdSet -foreign import ccall safe "select" +foreign import ccall safe "__hscore_select" c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal -> IO CInt @@ -1335,14 +1315,13 @@ #endif -reportStackOverflow :: IO a -reportStackOverflow = do callStackOverflowHook; return undefined +reportStackOverflow :: IO () +reportStackOverflow = callStackOverflowHook -reportError :: SomeException -> IO a +reportError :: SomeException -> IO () reportError ex = do handler <- getUncaughtExceptionHandler handler ex - return undefined -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove -- the unsafe below. @@ -1376,13 +1355,4 @@ getUncaughtExceptionHandler :: IO (SomeException -> IO ()) getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler - -withMVar :: MVar a -> (a -> IO b) -> IO b -withMVar m io = - block $ do - a <- takeMVar m - b <- catchAny (unblock (io a)) - (\e -> do putMVar m a; throw e) - putMVar m a - return b \end{code} diff --git a/lib/base/src/GHC/ConsoleHandler.hs b/lib/base/src/GHC/ConsoleHandler.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/ConsoleHandler.hs @@ -0,0 +1,156 @@ +{-# OPTIONS_GHC -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ConsoleHandler +-- Copyright : (c) The University of Glasgow +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- NB. the contents of this module are only available on Windows. +-- +-- Installing Win32 console handlers. +-- +----------------------------------------------------------------------------- + +module GHC.ConsoleHandler +#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__) + where +#else /* whole file */ + ( Handler(..) + , installHandler + , ConsoleEvent(..) + , flushConsole + ) where + +{- +#include "rts/Signals.h" +-} + +import Foreign +import Foreign.C +import GHC.IO.FD +import GHC.IO.Exception +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import GHC.Conc +import Control.Concurrent.MVar +import Data.Typeable + +#ifdef mingw32_HOST_OS +import Data.Maybe +import GHC.Base +import GHC.Num +import GHC.Real +#endif + +data Handler + = Default + | Ignore + | Catch (ConsoleEvent -> IO ()) + +-- | Allows Windows console events to be caught and handled. To +-- handle a console event, call 'installHandler' passing the +-- appropriate 'Handler' value. When the event is received, if the +-- 'Handler' value is @Catch f@, then a new thread will be spawned by +-- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that +-- was received. +-- +-- Note that console events can only be received by an application +-- running in a Windows console. Certain environments that look like consoles +-- do not support console events, these include: +-- +-- * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@, +-- then a Cygwin shell behaves like a Windows console). +-- * Cygwin xterm and rxvt windows +-- * MSYS rxvt windows +-- +-- In order for your application to receive console events, avoid running +-- it in one of these environments. +-- +installHandler :: Handler -> IO Handler +installHandler handler + | threaded = + modifyMVar win32ConsoleHandler $ \old_h -> do + (new_h,rc) <- + case handler of + Default -> do + r <- rts_installHandler STG_SIG_DFL nullPtr + return (no_handler, r) + Ignore -> do + r <- rts_installHandler STG_SIG_IGN nullPtr + return (no_handler, r) + Catch h -> do + r <- rts_installHandler STG_SIG_HAN nullPtr + return (h, r) + prev_handler <- + case rc of + STG_SIG_DFL -> return Default + STG_SIG_IGN -> return Ignore + STG_SIG_HAN -> return (Catch old_h) + _ -> error "installHandler: Bad threaded rc value" + return (new_h, prev_handler) + + | otherwise = + alloca $ \ p_sp -> do + rc <- + case handler of + Default -> rts_installHandler STG_SIG_DFL p_sp + Ignore -> rts_installHandler STG_SIG_IGN p_sp + Catch h -> do + v <- newStablePtr (toHandler h) + poke p_sp v + rts_installHandler STG_SIG_HAN p_sp + case rc of + STG_SIG_DFL -> return Default + STG_SIG_IGN -> return Ignore + STG_SIG_HAN -> do + osptr <- peek p_sp + oldh <- deRefStablePtr osptr + -- stable pointer is no longer in use, free it. + freeStablePtr osptr + return (Catch (\ ev -> oldh (fromConsoleEvent ev))) + _ -> error "installHandler: Bad non-threaded rc value" + where + fromConsoleEvent ev = + case ev of + ControlC -> 0 {- CTRL_C_EVENT-} + Break -> 1 {- CTRL_BREAK_EVENT-} + Close -> 2 {- CTRL_CLOSE_EVENT-} + Logoff -> 5 {- CTRL_LOGOFF_EVENT-} + Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-} + + toHandler hdlr ev = do + case toWin32ConsoleEvent ev of + -- see rts/win32/ConsoleHandler.c for comments as to why + -- rts_ConsoleHandlerDone is called here. + Just x -> hdlr x >> rts_ConsoleHandlerDone ev + Nothing -> return () -- silently ignore.. + + no_handler = error "win32ConsoleHandler" + +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool + +foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" + rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt +foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone" + rts_ConsoleHandlerDone :: CInt -> IO () + + +flushConsole :: Handle -> IO () +flushConsole h = + wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} -> + case cast dev of + Nothing -> ioException $ + IOError (Just h) IllegalOperation "flushConsole" + "handle is not a file descriptor" Nothing Nothing + Just fd -> do + throwErrnoIfMinus1Retry_ "flushConsole" $ + flush_console_fd (fromIntegral (fdFD fd)) + +foreign import ccall unsafe "consUtils.h flush_input_console__" + flush_console_fd :: CInt -> IO CInt + +#endif /* mingw32_HOST_OS */ diff --git a/lib/base/src/GHC/Constants.hs b/lib/base/src/GHC/Constants.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/Constants.hs @@ -0,0 +1,9 @@ + +module GHC.Constants where + +import Prelude + +-- We use stage1 here, because that's guaranteed to exist +#include "../../../compiler/stage1/ghc_boot_platform.h" + +#include "../../../includes/HaskellConstants.hs" diff --git a/lib/base/src/GHC/Desugar.hs b/lib/base/src/GHC/Desugar.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/Desugar.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Desugar +-- Copyright : (c) The University of Glasgow, 2007 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Support code for desugaring in GHC +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.Desugar ((>>>), AnnotationWrapper(..), toAnnotationWrapper) where + +import Control.Arrow (Arrow(..)) +import Control.Category ((.)) +import Data.Data (Data) + +-- A version of Control.Category.>>> overloaded on Arrow +#ifndef __HADDOCK__ +(>>>) :: forall arr. Arrow arr => forall a b c. arr a b -> arr b c -> arr a c +#endif +-- NB: the type of this function is the "shape" that GHC expects +-- in tcInstClassOp. So don't put all the foralls at the front! +-- Yes, this is a bit grotesque, but heck it works and the whole +-- arrows stuff needs reworking anyway! +f >>> g = g . f + +-- A wrapper data type that lets the typechecker get at the appropriate dictionaries for an annotation +data AnnotationWrapper = forall a. (Data a) => AnnotationWrapper a + +toAnnotationWrapper :: (Data a) => a -> AnnotationWrapper +toAnnotationWrapper what = AnnotationWrapper what diff --git a/lib/base/src/GHC/Enum.lhs b/lib/base/src/GHC/Enum.lhs --- a/lib/base/src/GHC/Enum.lhs +++ b/lib/base/src/GHC/Enum.lhs @@ -368,14 +368,14 @@ | delta >=# 0# = go_up_char_fb c n x1 delta 0x10FFFF# | otherwise = go_dn_char_fb c n x1 delta 0# where - delta = x2 -# x1 + !delta = x2 -# x1 efdChar :: Int# -> Int# -> String efdChar x1 x2 | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF# | otherwise = go_dn_char_list x1 delta 0# where - delta = x2 -# x1 + !delta = x2 -# x1 {-# NOINLINE [0] efdtCharFB #-} efdtCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a @@ -383,14 +383,14 @@ | delta >=# 0# = go_up_char_fb c n x1 delta lim | otherwise = go_dn_char_fb c n x1 delta lim where - delta = x2 -# x1 + !delta = x2 -# x1 efdtChar :: Int# -> Int# -> Int# -> String efdtChar x1 x2 lim | delta >=# 0# = go_up_char_list x1 delta lim | otherwise = go_dn_char_list x1 delta lim where - delta = x2 -# x1 + !delta = x2 -# x1 go_up_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a go_up_char_fb c n x0 delta lim @@ -453,7 +453,7 @@ {-# INLINE enumFrom #-} enumFrom (I# x) = eftInt x maxInt# - where I# maxInt# = maxInt + where !(I# maxInt#) = maxInt -- Blarg: technically I guess enumFrom isn't strict! {-# INLINE enumFromTo #-} @@ -528,8 +528,8 @@ efdtIntUp x1 x2 y -- Be careful about overflow! | y <# x2 = if y <# x1 then [] else [I# x1] | otherwise = -- Common case: x1 <= x2 <= y - let delta = x2 -# x1 -- >= 0 - y' = y -# delta -- x1 <= y' <= y; hence y' is representable + let !delta = x2 -# x1 -- >= 0 + !y' = y -# delta -- x1 <= y' <= y; hence y' is representable -- Invariant: x <= y -- Note that: z <= y' => z + delta won't overflow @@ -543,8 +543,8 @@ efdtIntUpFB c n x1 x2 y -- Be careful about overflow! | y <# x2 = if y <# x1 then n else I# x1 `c` n | otherwise = -- Common case: x1 <= x2 <= y - let delta = x2 -# x1 -- >= 0 - y' = y -# delta -- x1 <= y' <= y; hence y' is representable + let !delta = x2 -# x1 -- >= 0 + !y' = y -# delta -- x1 <= y' <= y; hence y' is representable -- Invariant: x <= y -- Note that: z <= y' => z + delta won't overflow @@ -558,8 +558,8 @@ efdtIntDn x1 x2 y -- Be careful about underflow! | y ># x2 = if y ># x1 then [] else [I# x1] | otherwise = -- Common case: x1 >= x2 >= y - let delta = x2 -# x1 -- <= 0 - y' = y -# delta -- y <= y' <= x1; hence y' is representable + let !delta = x2 -# x1 -- <= 0 + !y' = y -# delta -- y <= y' <= x1; hence y' is representable -- Invariant: x >= y -- Note that: z >= y' => z + delta won't underflow @@ -573,8 +573,8 @@ efdtIntDnFB c n x1 x2 y -- Be careful about underflow! | y ># x2 = if y ># x1 then n else I# x1 `c` n | otherwise = -- Common case: x1 >= x2 >= y - let delta = x2 -# x1 -- <= 0 - y' = y -# delta -- y <= y' <= x1; hence y' is representable + let !delta = x2 -# x1 -- <= 0 + !y' = y -# delta -- y <= y' <= x1; hence y' is representable -- Invariant: x >= y -- Note that: z >= y' => z + delta won't underflow diff --git a/lib/base/src/GHC/Environment.hs b/lib/base/src/GHC/Environment.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/Environment.hs @@ -0,0 +1,20 @@ + +module GHC.Environment (getFullArgs) where + +import Prelude +import Foreign +import Foreign.C +import Control.Monad + +getFullArgs :: IO [String] +getFullArgs = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getFullProgArgv p_argc p_argv + p <- fromIntegral `liftM` peek p_argc + argv <- peek p_argv + peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString + +foreign import ccall unsafe "getFullProgArgv" + getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + diff --git a/lib/base/src/GHC/Err.lhs-boot b/lib/base/src/GHC/Err.lhs-boot --- a/lib/base/src/GHC/Err.lhs-boot +++ b/lib/base/src/GHC/Err.lhs-boot @@ -4,7 +4,7 @@ -- Ghc.Err.hs-boot --------------------------------------------------------------------------- -module GHC.Err( error, divZeroError, overflowError ) where +module GHC.Err( error ) where -- The type signature for 'error' is a gross hack. -- First, we can't give an accurate type for error, because it mentions @@ -17,10 +17,4 @@ -- to mention 'error' so that it gets exported from this .hi-boot -- file. error :: a - --- divide by zero is needed quite early -divZeroError :: a - --- overflow is needed quite early -overflowError :: a \end{code} diff --git a/lib/base/src/GHC/Exception.lhs b/lib/base/src/GHC/Exception.lhs --- a/lib/base/src/GHC/Exception.lhs +++ b/lib/base/src/GHC/Exception.lhs @@ -19,7 +19,7 @@ module GHC.Exception where import Data.Maybe -import {-# SOURCE #-} Data.Typeable +import {-# SOURCE #-} Data.Typeable (Typeable, cast) import GHC.Base import GHC.Show \end{code} diff --git a/lib/base/src/GHC/Exts.hs b/lib/base/src/GHC/Exts.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/Exts.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exts +-- Copyright : (c) The University of Glasgow 2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- GHC Extensions: this is the Approved Way to get at GHC-specific extensions. +-- +----------------------------------------------------------------------------- + +module GHC.Exts + ( + -- * Representations of some basic types + Int(..),Word(..),Float(..),Double(..), + Char(..), + Ptr(..), FunPtr(..), + + -- * The maximum tuple size + maxTupleSize, + + -- * Primitive operations + module GHC.Prim, + shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#, + uncheckedShiftL64#, uncheckedShiftRL64#, + uncheckedIShiftL64#, uncheckedIShiftRA64#, + + -- * Fusion + build, augment, + + -- * Overloaded string literals + IsString(..), + + -- * Debugging + breakpoint, breakpointCond, + + -- * Ids with special behaviour + lazy, inline, + + -- * Transform comprehensions + Down(..), groupWith, sortWith, the, + + -- * Event logging + traceEvent + + ) where + +import Prelude + +import GHC.Prim +import GHC.Base +import GHC.Magic +import GHC.Word +import GHC.Int +-- import GHC.Float +import GHC.Ptr +import Data.String +import Data.List +import Foreign.C + +-- XXX This should really be in Data.Tuple, where the definitions are +maxTupleSize :: Int +maxTupleSize = 62 + +-- | The 'Down' type allows you to reverse sort order conveniently. A value of type +-- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@). +-- If @a@ has an @'Ord'@ instance associated with it then comparing two +-- values thus wrapped will give you the opposite of their normal sort order. +-- This is particularly useful when sorting in generalised list comprehensions, +-- as in: @then sortWith by 'Down' x@ +newtype Down a = Down a deriving (Eq) + +instance Ord a => Ord (Down a) where + compare (Down x) (Down y) = y `compare` x + +-- | 'the' ensures that all the elements of the list are identical +-- and then returns that unique element +the :: Eq a => [a] -> a +the (x:xs) + | all (x ==) xs = x + | otherwise = error "GHC.Exts.the: non-identical elements" +the [] = error "GHC.Exts.the: empty list" + +-- | The 'sortWith' function sorts a list of elements using the +-- user supplied function to project something out of each element +sortWith :: Ord b => (a -> b) -> [a] -> [a] +sortWith f = sortBy (\x y -> compare (f x) (f y)) + +-- | The 'groupWith' function uses the user supplied function which +-- projects an element out of every list element in order to to first sort the +-- input list and then to form groups by equality on these projected elements +{-# INLINE groupWith #-} +groupWith :: Ord b => (a -> b) -> [a] -> [[a]] +groupWith f xs = build (\c n -> groupByFB c n (\x y -> f x == f y) (sortWith f xs)) + +groupByFB :: ([a] -> lst -> lst) -> lst -> (a -> a -> Bool) -> [a] -> lst +groupByFB c n eq xs0 = groupByFBCore xs0 + where groupByFBCore [] = n + groupByFBCore (x:xs) = c (x:ys) (groupByFBCore zs) + where (ys, zs) = span (eq x) xs + + +-- ----------------------------------------------------------------------------- +-- tracing + +traceEvent :: String -> IO () +traceEvent msg = do + withCString msg $ \(Ptr p) -> IO $ \s -> + case traceEvent# p s of s' -> (# s', () #) diff --git a/lib/base/src/GHC/Float.lhs b/lib/base/src/GHC/Float.lhs --- a/lib/base/src/GHC/Float.lhs +++ b/lib/base/src/GHC/Float.lhs @@ -1,5 +1,7 @@ \begin{code} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +-- We believe we could deorphan this module, by moving lots of things +-- around, but we haven't got there yet: {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -24,6 +26,7 @@ import Data.Maybe +import Data.Bits import GHC.Base import GHC.List import GHC.Enum @@ -56,6 +59,11 @@ sinh, cosh, tanh :: a -> a asinh, acosh, atanh :: a -> a + {-# INLINE (**) #-} + {-# INLINE logBase #-} + {-# INLINE sqrt #-} + {-# INLINE tan #-} + {-# INLINE tanh #-} x ** y = exp (log x * y) logBase x y = log y / log x sqrt x = x ** 0.5 @@ -148,19 +156,6 @@ %********************************************************* \begin{code} -instance Eq Float where - (F# x) == (F# y) = x `eqFloat#` y - -instance Ord Float where - (F# x) `compare` (F# y) | x `ltFloat#` y = LT - | x `eqFloat#` y = EQ - | otherwise = GT - - (F# x) < (F# y) = x `ltFloat#` y - (F# x) <= (F# y) = x `leFloat#` y - (F# x) >= (F# y) = x `geFloat#` y - (F# x) > (F# y) = x `gtFloat#` y - instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y @@ -199,16 +194,22 @@ {-# INLINE floor #-} {-# INLINE truncate #-} - properFraction x - = case (decodeFloat x) of { (m,n) -> - let b = floatRadix x in - if n >= 0 then - (fromInteger m * fromInteger b ^ n, 0.0) - else - case (quotRem m (b^(negate n))) of { (w,r) -> - (fromInteger w, encodeFloat r n) - } - } +-- We assume that FLT_RADIX is 2 so that we can use more efficient code +#if FLT_RADIX != 2 +#error FLT_RADIX must be 2 +#endif + properFraction (F# x#) + = case decodeFloat_Int# x# of + (# m#, n# #) -> + let m = I# m# + n = I# n# + in + if n >= 0 + then (fromIntegral m * (2 ^ n), 0.0) + else let i = if m >= 0 then m `shiftR` negate n + else negate (negate m `shiftR` negate n) + f = m - (i `shiftL` negate n) + in (fromIntegral i, encodeFloat (fromIntegral f) n) truncate x = case properFraction x of (n,_) -> n @@ -255,10 +256,10 @@ floatDigits _ = FLT_MANT_DIG -- ditto floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto - decodeFloat (F# f#) = error "decodeFloat"{-case decodeFloatInteger f# of - (# i, e #) -> (i, I# e)-} + decodeFloat (F# f#) = case decodeFloat_Int# f# of + (# i, e #) -> (smallInteger i, I# e) - encodeFloat i (I# e) = error "encodeFloat" --F# (encodeFloatInteger i e) + encodeFloat i (I# e) = error "encodeFloat" -- F# (encodeFloatInteger i e) exponent x = case decodeFloat x of (m,n) -> if m == 0 then 0 else n + floatDigits x @@ -286,19 +287,6 @@ %********************************************************* \begin{code} -instance Eq Double where - (D# x) == (D# y) = x ==## y - -instance Ord Double where - (D# x) `compare` (D# y) | x <## y = LT - | x ==## y = EQ - | otherwise = GT - - (D# x) < (D# y) = x <## y - (D# x) <= (D# y) = x <=## y - (D# x) >= (D# y) = x >=## y - (D# x) > (D# y) = x >## y - instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y @@ -395,10 +383,10 @@ floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto decodeFloat (D# x#) - = error "decodeFloat" {-case decodeDoubleInteger x# of - (# i, j #) -> (i, I# j)-} + = error "decodeFloat" --case decodeDoubleInteger x# of +-- (# i, j #) -> (i, I# j) - encodeFloat i (I# j) = error "encodeFloat" {-D# (encodeDoubleInteger i j)-} + encodeFloat i (I# j) = error "encodeFloat" -- D# (encodeDoubleInteger i j) exponent x = case decodeFloat x of (m,n) -> if m == 0 then 0 else n + floatDigits x @@ -618,7 +606,9 @@ -- Haskell promises that p-1 <= logBase b f < p. (p - 1 + e0) * 3 `div` 10 else - ceiling ((log (fromInteger (f+1)) + + -- f :: Integer, log :: Float -> Float, + -- ceiling :: Float -> Int + ceiling ((log (fromInteger (f+1) :: Float) + fromIntegral e * log (fromInteger b)) / log (fromInteger base)) --WAS: fromInt e * log (fromInteger b)) @@ -896,20 +886,11 @@ \end{code} \begin{code} -foreign import ccall unsafe "__encodeFloat" - encodeFloat# :: Int# -> ByteArray# -> Int -> Float -foreign import ccall unsafe "__int_encodeFloat" - int_encodeFloat# :: Int# -> Int -> Float - - foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int - -foreign import ccall unsafe "__encodeDouble" - encodeDouble# :: Int# -> ByteArray# -> Int -> Double foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int diff --git a/lib/base/src/GHC/ForeignPtr.hs b/lib/base/src/GHC/ForeignPtr.hs --- a/lib/base/src/GHC/ForeignPtr.hs +++ b/lib/base/src/GHC/ForeignPtr.hs @@ -37,16 +37,18 @@ import Control.Monad ( sequence_ ) import Foreign.Storable ---import Data.Typeable +import Data.Typeable import GHC.Show import GHC.List ( null ) import GHC.Base -import GHC.IOBase +import GHC.IORef import GHC.STRef ( STRef(..) ) import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Err +import GHC.Num ( fromInteger ) +#include "Typeable.h" -- |The type 'ForeignPtr' represents references to objects that are -- maintained in a foreign language, i.e., that are not part of the @@ -75,7 +77,7 @@ -- object, because that ensures that whatever the finalizer is -- attached to is kept alive. -{-INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")-} +INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr") data Finalizers = NoFinalizers @@ -148,19 +150,23 @@ -- mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) - doMalloc a = do + doMalloc a + | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | otherwise = do r <- newIORef (NoFinalizers, []) IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (MallocPtr mbarr# r) #) } - where (I# size) = sizeOf a - (I# align) = alignment a + where !(I# size) = sizeOf a + !(I# align) = alignment a -- | This function is similar to 'mallocForeignPtr', except that the -- size of the memory required is given explicitly as a number of bytes. mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) +mallocForeignPtrBytes size | size < 0 = + error "mallocForeignPtrBytes: size must be >= 0" mallocForeignPtrBytes (I# size) = do r <- newIORef (NoFinalizers, []) IO $ \s -> @@ -185,19 +191,23 @@ mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a) mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) - doMalloc a = IO $ \s -> + doMalloc a + | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | otherwise = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) } - where (I# size) = sizeOf a - (I# align) = alignment a + where !(I# size) = sizeOf a + !(I# align) = alignment a -- | This function is similar to 'mallocForeignPtrBytes', except that -- the internally an optimised ForeignPtr representation with no -- finalizer is used. Attempts to add a finalizer will cause an -- exception to be thrown. mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a) +mallocPlainForeignPtrBytes size | size < 0 = + error "mallocPlainForeignPtrBytes: size must be >= 0" mallocPlainForeignPtrBytes (I# size) = IO $ \s -> case newPinnedByteArray# size s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -212,7 +222,7 @@ PlainForeignPtr r -> f r >> return () MallocPtr _ r -> f r >> return () _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" - where + where f r = noMixing CFinalizers r $ IO $ \s -> @@ -230,7 +240,7 @@ PlainForeignPtr r -> f r >> return () MallocPtr _ r -> f r >> return () _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" - where + where f r = noMixing CFinalizers r $ IO $ \s -> diff --git a/lib/base/src/GHC/Handle.hs b/lib/base/src/GHC/Handle.hs --- a/lib/base/src/GHC/Handle.hs +++ b/lib/base/src/GHC/Handle.hs @@ -1,1843 +1,55 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_HADDOCK hide #-} - -#undef DEBUG_DUMP -#undef DEBUG - ------------------------------------------------------------------------------ --- | --- Module : GHC.Handle --- Copyright : (c) The University of Glasgow, 1994-2001 --- License : see libraries/base/LICENSE --- --- Maintainer : libraries@haskell.org --- Stability : internal --- Portability : non-portable --- --- This module defines the basic operations on I\/O \"handles\". --- ------------------------------------------------------------------------------ - --- #hide -module GHC.Handle ( - withHandle, withHandle', withHandle_, - wantWritableHandle, wantReadableHandle, wantSeekableHandle, - - newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, - fillReadBuffer, fillReadBufferWithoutBlocking, - readRawBuffer, readRawBufferPtr, - readRawBufferNoBlock, readRawBufferPtrNoBlock, - writeRawBuffer, writeRawBufferPtr, - -#ifndef mingw32_HOST_OS - unlockFile, -#endif - - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, - - stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle', - hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode, - hFlush, hDuplicate, hDuplicateTo, - - hClose, hClose_help, - - HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, hTell, - - hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, - hSetEcho, hGetEcho, hIsTerminalDevice, - - hShow, - -#ifdef DEBUG_DUMP - puts, -#endif - - ) where - -import Control.Monad -import Data.Maybe -import Foreign -import Foreign.C -import System.IO.Error -import System.Posix.Internals -import System.Posix.Types - -import GHC.Real - -import GHC.Arr -import GHC.Base -import GHC.Read ( Read ) -import GHC.List -import GHC.IOBase -import GHC.Exception -import GHC.Enum -import GHC.Num ( Integer, Num(..) ) -import GHC.Show -#if defined(DEBUG_DUMP) -import GHC.Pack -#endif - -import GHC.Conc - --- ----------------------------------------------------------------------------- --- TODO: - --- hWaitForInput blocks (should use a timeout) - --- unbuffered hGetLine is a bit dodgy - --- hSetBuffering: can't change buffering on a stream, --- when the read buffer is non-empty? (no way to flush the buffer) - --- --------------------------------------------------------------------------- --- Are files opened by default in text or binary mode, if the user doesn't --- specify? - -dEFAULT_OPEN_IN_BINARY_MODE :: Bool -dEFAULT_OPEN_IN_BINARY_MODE = False - --- --------------------------------------------------------------------------- --- Creating a new handle - -newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle -newFileHandle filepath finalizer hc = do - m <- newMVar hc - addMVarFinalizer m (finalizer m) - return (FileHandle filepath m) - --- --------------------------------------------------------------------------- --- Working with Handles - -{- -In the concurrent world, handles are locked during use. This is done -by wrapping an MVar around the handle which acts as a mutex over -operations on the handle. - -To avoid races, we use the following bracketing operations. The idea -is to obtain the lock, do some operation and replace the lock again, -whether the operation succeeded or failed. We also want to handle the -case where the thread receives an exception while processing the IO -operation: in these cases we also want to relinquish the lock. - -There are three versions of @withHandle@: corresponding to the three -possible combinations of: - - - the operation may side-effect the handle - - the operation may return a result - -If the operation generates an error or an exception is raised, the -original handle is always replaced [ this is the case at the moment, -but we might want to revisit this in the future --SDM ]. --} - -{-# INLINE withHandle #-} -withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act -withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act - -withHandle' :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkBufferInvariants h' - putMVar m h' - return v - -{-# INLINE withHandle_ #-} -withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a -withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act -withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act - -withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkBufferInvariants h_ - putMVar m h_ - return v - -withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () -withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act -withAllHandles__ fun h@(DuplexHandle _ r w) act = do - withHandle__' fun h r act - withHandle__' fun h w act - -withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) - -> IO () -withHandle__' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkBufferInvariants h' - putMVar m h' - return () - -augmentIOError :: IOException -> String -> Handle -> IOException -augmentIOError (IOError _ iot _ str fp) fun h - = IOError (Just h) iot fun str filepath - where filepath - | Just _ <- fp = fp - | otherwise = case h of - FileHandle path _ -> Just path - DuplexHandle path _ _ -> Just path - --- --------------------------------------------------------------------------- --- Wrapper for write operations. - -wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantWritableHandle fun h@(FileHandle _ m) act - = wantWritableHandle' fun h m act -wantWritableHandle fun h@(DuplexHandle _ _ m) act - = wantWritableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkWritableHandle - -wantWritableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantWritableHandle' fun h m act - = withHandle_' fun h m (checkWritableHandle act) - -checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a -checkWritableHandle act handle_ - = case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - ReadHandle -> ioe_notWritable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - new_buf <- - if not (bufferIsWritable buf) - then do b <- flushReadBuffer (haFD handle_) buf - return b{ bufState=WriteBuffer } - else return buf - writeIORef ref new_buf - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for read operations. - -wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantReadableHandle fun h@(FileHandle _ m) act - = wantReadableHandle' fun h m act -wantReadableHandle fun h@(DuplexHandle _ m _) act - = wantReadableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkReadableHandle - -wantReadableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantReadableHandle' fun h m act - = withHandle_' fun h m (checkReadableHandle act) - -checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a -checkReadableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef ref new_buf{ bufState=ReadBuffer } - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for seek operations. - -wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = - ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing) -wantSeekableHandle fun h@(FileHandle _ m) act = - withHandle_' fun h m (checkSeekableHandle act) - -checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a -checkSeekableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notSeekable - _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_ - | otherwise -> ioe_notSeekable_notBin - --- ----------------------------------------------------------------------------- --- Handy IOErrors - -ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, - ioe_notSeekable, ioe_notSeekable_notBin :: IO a - -ioe_closedHandle = ioException - (IOError Nothing IllegalOperation "" - "handle is closed" Nothing) -ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing) -ioe_notReadable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing) -ioe_notWritable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing) -ioe_notSeekable = ioException - (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing) -ioe_notSeekable_notBin = ioException - (IOError Nothing IllegalOperation "" - "seek operations on text-mode handles are not allowed on this platform" - Nothing) - -ioe_finalizedHandle :: FilePath -> Handle__ -ioe_finalizedHandle fp = throw - (IOError Nothing IllegalOperation "" - "handle is finalized" (Just fp)) - -ioe_bufsiz :: Int -> IO a -ioe_bufsiz n = ioException - (IOError Nothing InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing) - -- 9 => should be parens'ified. - --- ----------------------------------------------------------------------------- --- Handle Finalizers - --- For a duplex handle, we arrange that the read side points to the write side --- (and hence keeps it alive if the read side is alive). This is done by --- having the haOtherSide field of the read side point to the read side. --- The finalizer is then placed on the write side, and the handle only gets --- finalized once, when both sides are no longer required. - --- NOTE about finalized handles: It's possible that a handle can be --- finalized and then we try to use it later, for example if the --- handle is referenced from another finalizer, or from a thread that --- has become unreferenced and then resurrected (arguably in the --- latter case we shouldn't finalize the Handle...). Anyway, --- we try to emit a helpful message which is better than nothing. - -stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () -stdHandleFinalizer fp m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ - putMVar m (ioe_finalizedHandle fp) - -handleFinalizer :: FilePath -> MVar Handle__ -> IO () -handleFinalizer fp m = do - handle_ <- takeMVar m - case haType handle_ of - ClosedHandle -> return () - _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return () - -- ignore errors and async exceptions, and close the - -- descriptor anyway... - hClose_handle_ handle_ - return () - putMVar m (ioe_finalizedHandle fp) - --- --------------------------------------------------------------------------- --- Grimy buffer operations - -checkBufferInvariants :: Handle__ -> IO () -#ifdef DEBUG -checkBufferInvariants h_ = do - let ref = haBuffer h_ - Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref - if not ( - size > 0 - && r <= w - && w <= size - && ( r /= w || (r == 0 && w == 0) ) - && ( state /= WriteBuffer || r == 0 ) - && ( state /= WriteBuffer || w < size ) -- write buffer is never full - ) - then error "buffer invariant violation" - else return () -#else -checkBufferInvariants _ = return () -#endif - -newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer -newEmptyBuffer b state size - = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state } - -allocateBuffer :: Int -> BufferState -> IO Buffer -allocateBuffer sz@(I# size) state = IO $ \s -> - -- We sometimes need to pass the address of this buffer to - -- a "safe" foreign call, hence it must be immovable. - case newPinnedByteArray# size s of { (# s', b #) -> - (# s', newEmptyBuffer b state sz #) } - -writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int -writeCharIntoBuffer slab (I# off) (C# c) - = IO $ \s -> case writeCharArray# slab off c s of - s' -> (# s', I# (off +# 1#) #) - -readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int) -readCharFromBuffer slab (I# off) - = IO $ \s -> case readCharArray# slab off s of - (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #) - -getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) -getBuffer fd state = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state - ioref <- newIORef buffer - is_tty <- fdIsTTY fd - - let buffer_mode - | is_tty = LineBuffering - | otherwise = BlockBuffering Nothing - - return (ioref, buffer_mode) - -mkUnBuffer :: IO (IORef Buffer) -mkUnBuffer = do - buffer <- allocateBuffer 1 ReadBuffer - newIORef buffer - --- flushWriteBufferOnly flushes the buffer iff it contains pending write data. -flushWriteBufferOnly :: Handle__ -> IO () -flushWriteBufferOnly h_ = do - let fd = haFD h_ - ref = haBuffer h_ - buf <- readIORef ref - new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd (haIsStream h_) buf - else return buf - writeIORef ref new_buf - --- flushBuffer syncs the file with the buffer, including moving the --- file pointer backwards in the case of a read buffer. -flushBuffer :: Handle__ -> IO () -flushBuffer h_ = do - let ref = haBuffer h_ - buf <- readIORef ref - - flushed_buf <- - case bufState buf of - ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf - - writeIORef ref flushed_buf - --- When flushing a read buffer, we seek backwards by the number of --- characters in the buffer. The file descriptor must therefore be --- seekable: attempting to flush the read buffer on an unseekable --- handle is not allowed. - -flushReadBuffer :: FD -> Buffer -> IO Buffer -flushReadBuffer fd buf - | bufferEmpty buf = return buf - | otherwise = do - let off = negate (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") -# endif - throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek fd (fromIntegral off) sEEK_CUR) - return buf{ bufWPtr=0, bufRPtr=0 } - -flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer -flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = - seq fd $ do -- strictness hack - let bytes = w - r -#ifdef DEBUG_DUMP - puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") -#endif - if bytes == 0 - then return (buf{ bufRPtr=0, bufWPtr=0 }) - else do - res <- writeRawBuffer "flushWriteBuffer" fd is_stream b - (fromIntegral r) (fromIntegral bytes) - let res' = fromIntegral res - if res' < bytes - then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) - else return buf{ bufRPtr=0, bufWPtr=0 } - -fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line is_stream - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line is_stream buf b w size - --- For a line buffer, we just get the first chunk of data to arrive, --- and don't wait for the whole buffer to be full (but we *do* wait --- until some data arrives). This isn't really line buffering, but it --- appears to be what GHC has done for a long time, and I suspect it --- is more useful than line buffering in most cases. - -fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int - -> IO Buffer -fillReadBufferLoop fd is_line is_stream buf b w size = do - let bytes = size - w - if bytes == 0 -- buffer full? - then return buf{ bufRPtr=0, bufWPtr=w } - else do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") -#endif - res <- readRawBuffer "fillReadBuffer" fd is_stream b - (fromIntegral w) (fromIntegral bytes) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n") -#endif - if res' == 0 - then if w == 0 - then ioe_EOF - else return buf{ bufRPtr=0, bufWPtr=w } - else if res' < bytes && not is_line - then fillReadBufferLoop fd is_line is_stream buf b (w+res') size - else return buf{ bufRPtr=0, bufWPtr=w+res' } - - -fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer -fillReadBufferWithoutBlocking fd is_stream - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n") -#endif - res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b - 0 (fromIntegral size) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n") -#endif - return buf{ bufRPtr=0, bufWPtr=res' } - --- Low level routines for reading/writing to (raw)buffers: - -#ifndef mingw32_HOST_OS - -{- -NOTE [nonblock]: - -Unix has broken semantics when it comes to non-blocking I/O: you can -set the O_NONBLOCK flag on an FD, but it applies to the all other FDs -attached to the same underlying file, pipe or TTY; there's no way to -have private non-blocking behaviour for an FD. See bug #724. - -We fix this by only setting O_NONBLOCK on FDs that we create; FDs that -come from external sources or are exposed externally are left in -blocking mode. This solution has some problems though. We can't -completely simulate a non-blocking read without O_NONBLOCK: several -cases are wrong here. The cases that are wrong: - - * reading/writing to a blocking FD in non-threaded mode. - In threaded mode, we just make a safe call to read(). - In non-threaded mode we call select() before attempting to read, - but that leaves a small race window where the data can be read - from the file descriptor before we issue our blocking read(). - * readRawBufferNoBlock for a blocking FD - -NOTE [2363]: - -In the threaded RTS we could just make safe calls to read()/write() -for file descriptors in blocking mode without worrying about blocking -other threads, but the problem with this is that the thread will be -uninterruptible while it is blocked in the foreign call. See #2363. -So now we always call fdReady() before reading, and if fdReady -indicates that there's no data, we call threadWaitRead. - --} - -readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBuffer loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- throwErrnoIfMinus1 loc - (unsafe_fdReady (fromIntegral fd) 0 0 0) - if r /= 0 - then read - else do threadWaitRead (fromIntegral fd); read - where - do_read call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitRead (fromIntegral fd)) - read = if threaded then safe_read else unsafe_read - unsafe_read = do_read (read_rawBuffer fd buf off len) - safe_read = do_read (safe_read_rawBuffer fd buf off len) - -readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtr loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- throwErrnoIfMinus1 loc - (unsafe_fdReady (fromIntegral fd) 0 0 0) - if r /= 0 - then read - else do threadWaitRead (fromIntegral fd); read - where - do_read call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitRead (fromIntegral fd)) - read = if threaded then safe_read else unsafe_read - unsafe_read = do_read (read_off fd buf off len) - safe_read = do_read (safe_read_off fd buf off len) - -readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBufferNoBlock loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0 - if r /= 0 then safe_read - else return 0 - -- XXX see note [nonblock] - where - do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0) - unsafe_read = do_read (read_rawBuffer fd buf off len) - safe_read = do_read (safe_read_rawBuffer fd buf off len) - -readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtrNoBlock loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0 - if r /= 0 then safe_read - else return 0 - -- XXX see note [nonblock] - where - do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0) - unsafe_read = do_read (read_off fd buf off len) - safe_read = do_read (safe_read_off fd buf off len) - -writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -writeRawBuffer loc fd is_nonblock buf off len - | is_nonblock = unsafe_write -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0 - if r /= 0 - then write - else do threadWaitWrite (fromIntegral fd); write - where - do_write call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitWrite (fromIntegral fd)) - write = if threaded then safe_write else unsafe_write - unsafe_write = do_write (write_rawBuffer fd buf off len) - safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len) - -writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -writeRawBufferPtr loc fd is_nonblock buf off len - | is_nonblock = unsafe_write -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0 - if r /= 0 - then write - else do threadWaitWrite (fromIntegral fd); write - where - do_write call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitWrite (fromIntegral fd)) - write = if threaded then safe_write else unsafe_write - unsafe_write = do_write (write_off fd buf off len) - safe_write = do_write (safe_write_off (fromIntegral fd) buf off len) - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "fdReady" - unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt - -#else /* mingw32_HOST_OS.... */ - -readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBuffer loc fd is_stream buf off len - | threaded = blockingReadRawBuffer loc fd is_stream buf off len - | otherwise = asyncReadRawBuffer loc fd is_stream buf off len - -readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtr loc fd is_stream buf off len - | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len - | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len - -writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -writeRawBuffer loc fd is_stream buf off len - | threaded = blockingWriteRawBuffer loc fd is_stream buf off len - | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len - -writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -writeRawBufferPtr loc fd is_stream buf off len - | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len - | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len - --- ToDo: we don't have a non-blocking primitve read on Win32 -readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBufferNoBlock = readRawBuffer - -readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtrNoBlock = readRawBufferPtr --- Async versions of the read/write primitives, for the non-threaded RTS - -asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -asyncReadRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) off buf - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt - -> IO CInt -asyncReadRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) (buf `plusPtr` off) - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -asyncWriteRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) off buf - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt - -> IO CInt -asyncWriteRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) (buf `plusPtr` off) - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - --- Blocking versions of the read/write primitives, for the threaded RTS - -blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -blockingReadRawBuffer loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_recv_rawBuffer fd buf off len -blockingReadRawBuffer loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_read_rawBuffer fd buf off len - -blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt - -> IO CInt -blockingReadRawBufferPtr loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_recv_off fd buf off len -blockingReadRawBufferPtr loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_read_off fd buf off len - -blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -blockingWriteRawBuffer loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_send_rawBuffer fd buf off len -blockingWriteRawBuffer loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_write_rawBuffer fd buf off len - -blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt - -> IO CInt -blockingWriteRawBufferPtr loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_send_off fd buf off len -blockingWriteRawBufferPtr loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_write_off fd buf off len - --- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. --- These calls may block, but that's ok. - -foreign import ccall safe "__hscore_PrelHandle_recv" - safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_recv" - safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_send" - safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_send" - safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -#endif - -foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool - -foreign import ccall safe "__hscore_PrelHandle_read" - safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_read" - safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_write" - safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_write" - safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - --- --------------------------------------------------------------------------- --- Standard Handles - --- Three handles are allocated during program initialisation. The first --- two manage input or output from the Haskell program's standard input --- or output channel respectively. The third manages output to the --- standard error channel. These handles are initially open. - -fd_stdin, fd_stdout, fd_stderr :: FD -fd_stdin = 0 -fd_stdout = 1 -fd_stderr = 2 - --- | A handle managing input from the Haskell program's standard input channel. -stdin :: Handle -stdin = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on standard handles, because it may - -- confuse other applications attached to the same TTY/pipe - -- see Note [nonblock] - (buf, bmode) <- getBuffer fd_stdin ReadBuffer - mkStdHandle fd_stdin "" ReadHandle buf bmode - --- | A handle managing output to the Haskell program's standard output channel. -stdout :: Handle -stdout = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on standard handles, because it may - -- confuse other applications attached to the same TTY/pipe - -- see Note [nonblock] - (buf, bmode) <- getBuffer fd_stdout WriteBuffer - mkStdHandle fd_stdout "" WriteHandle buf bmode - --- | A handle managing output to the Haskell program's standard error channel. -stderr :: Handle -stderr = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on standard handles, because it may - -- confuse other applications attached to the same TTY/pipe - -- see Note [nonblock] - buf <- mkUnBuffer - mkStdHandle fd_stderr "" WriteHandle buf NoBuffering - --- --------------------------------------------------------------------------- --- Opening and Closing Files - -addFilePathToIOError :: String -> FilePath -> IOException -> IOException -addFilePathToIOError fun fp (IOError h iot _ str _) - = IOError h iot fun str (Just fp) - --- | Computation 'openFile' @file mode@ allocates and returns a new, open --- handle to manage the file @file@. It manages input if @mode@ --- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', --- and both input and output if mode is 'ReadWriteMode'. --- --- If the file does not exist and it is opened for output, it should be --- created as a new file. If @mode@ is 'WriteMode' and the file --- already exists, then it should be truncated to zero length. --- Some operating systems delete empty files, so there is no guarantee --- that the file will exist following an 'openFile' with @mode@ --- 'WriteMode' unless it is subsequently written to successfully. --- The handle is positioned at the end of the file if @mode@ is --- 'AppendMode', and otherwise at the beginning (in which case its --- internal position is 0). --- The initial buffer mode is implementation-dependent. --- --- This operation may fail with: --- --- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; --- --- * 'isDoesNotExistError' if the file does not exist; or --- --- * 'isPermissionError' if the user does not have permission to open the file. --- --- Note: if you will be working with files containing binary data, you'll want to --- be using 'openBinaryFile'. -openFile :: FilePath -> IOMode -> IO Handle -openFile fp im = - catch - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) - --- | Like 'openFile', but open the file in binary mode. --- On Windows, reading a file in text mode (which is the default) --- will translate CRLF to LF, and writing will translate LF to CRLF. --- This is usually what you want with text files. With binary files --- this is undesirable; also, as usual under Microsoft operating systems, --- text mode treats control-Z as EOF. Binary mode turns off all special --- treatment of end-of-line and end-of-file characters. --- (See also 'hSetBinaryMode'.) - -openBinaryFile :: FilePath -> IOMode -> IO Handle -openBinaryFile fp m = - catch - (openFile' fp m True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) - -openFile' :: String -> IOMode -> Bool -> IO Handle -openFile' filepath mode binary = - withCString filepath $ \ f -> - - let - oflags1 = case mode of - ReadMode -> read_flags -#ifdef mingw32_HOST_OS - WriteMode -> write_flags .|. o_TRUNC -#else - WriteMode -> write_flags -#endif - ReadWriteMode -> rw_flags - AppendMode -> append_flags - - binary_flags - | binary = o_BINARY - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - in do - - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- throwErrnoIfMinus1Retry "openFile" - (c_open f (fromIntegral oflags) 0o666) - - stat@(fd_type,_,_) <- fdStat fd - - h <- fdToHandle_stat fd (Just stat) - False -- set_non_blocking - True -- is_non_blocking - False -- is_socket - filepath mode binary - `catchAny` \e -> do c_close fd; throw e - -- NB. don't forget to close the FD if fdToHandle' fails, otherwise - -- this FD leaks. - -- ASSERT: if we just created the file, then fdToHandle' won't fail - -- (so we don't need to worry about removing the newly created file - -- in the event of an error). - -#ifndef mingw32_HOST_OS - -- we want to truncate() if this is an open in WriteMode, but only - -- if the target is a RegularFile. ftruncate() fails on special files - -- like /dev/null. - if mode == WriteMode && fd_type == RegularFile - then throwErrnoIf (/=0) "openFile" - (c_ftruncate fd 0) - else return 0 -#endif - return h - - -std_flags, output_flags, read_flags, write_flags, rw_flags, - append_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY -rw_flags = output_flags .|. o_RDWR -append_flags = write_flags .|. o_APPEND - --- --------------------------------------------------------------------------- --- fdToHandle - -fdToHandle_stat :: FD - -> Maybe (FDType, CDev, CIno) - -> Bool -- set_non_blocking - -> Bool -- is_non_blocking - -> Bool -- is_socket - -> FilePath - -> IOMode - -> Bool - -> IO Handle - -fdToHandle_stat fd mb_stat set_non_blocking is_non_blocking is_socket - filepath mode binary = do - -#ifdef mingw32_HOST_OS - -- On Windows, the is_stream flag indicates that the Handle is a socket - let is_stream = is_socket -#else - when set_non_blocking $ setNonBlockingFD fd - -- turn on non-blocking mode - - -- On Unix, the is_stream flag indicates that the FD is in non-blocking mode - let is_stream = is_non_blocking || set_non_blocking -#endif - - let (ha_type, write) = - case mode of - ReadMode -> ( ReadHandle, False ) - WriteMode -> ( WriteHandle, True ) - ReadWriteMode -> ( ReadWriteHandle, True ) - AppendMode -> ( AppendHandle, True ) - - -- open() won't tell us if it was a directory if we only opened for - -- reading, so check again. - (fd_type,dev,ino) <- - case mb_stat of - Just x -> return x - Nothing -> fdStat fd - - case fd_type of - Directory -> - ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing) - - -- regular files need to be locked - RegularFile -> do -#ifndef mingw32_HOST_OS - -- On Windows we use explicit exclusion via sopen() to implement - -- this locking (see __hscore_open()); on Unix we have to - -- implment it in the RTS. - r <- lockFile fd dev ino (fromBool write) - when (r == -1) $ - ioException (IOError Nothing ResourceBusy "openFile" - "file is locked" Nothing) -#endif - mkFileHandle fd is_stream filepath ha_type binary - - Stream - -- only *Streams* can be DuplexHandles. Other read/write - -- Handles must share a buffer. - | ReadWriteHandle <- ha_type -> - mkDuplexHandle fd is_stream filepath binary - | otherwise -> - mkFileHandle fd is_stream filepath ha_type binary - - RawDevice -> - mkFileHandle fd is_stream filepath ha_type binary - --- | Old API kept to avoid breaking clients -fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool - -> IO Handle -fdToHandle' fd mb_type is_socket filepath mode binary - = do - let mb_stat = case mb_type of - Nothing -> Nothing - -- fdToHandle_stat will do the stat: - Just RegularFile -> Nothing - -- no stat required for streams etc.: - Just other -> Just (other,0,0) - fdToHandle_stat fd mb_stat - is_socket -- set_non_blocking - False -- is_non_blocking - is_socket -- is_socket - filepath mode binary - -fdToHandle :: FD -> IO Handle -fdToHandle fd = do - mode <- fdGetMode fd - let fd_str = "" - fdToHandle_stat fd Nothing - False -- set_non_blocking - False -- is_non_blocking - False -- is_socket (guess XXX) - fd_str mode True{-bin mode-} - -#ifndef mingw32_HOST_OS -foreign import ccall unsafe "lockFile" - lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt - -foreign import ccall unsafe "unlockFile" - unlockFile :: CInt -> IO CInt -#endif - -mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode - -> IO Handle -mkStdHandle fd filepath ha_type buf bmode = do - spares <- newIORef BufferListNil - newFileHandle filepath (stdHandleFinalizer filepath) - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haIsStream = False, -- means FD is blocking on Unix - haBufferMode = bmode, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle -mkFileHandle fd is_stream filepath ha_type binary = do - (buf, bmode) <- getBuffer fd (initBufferState ha_type) - -#ifdef mingw32_HOST_OS - -- On Windows, if this is a read/write handle and we are in text mode, - -- turn off buffering. We don't correctly handle the case of switching - -- from read mode to write mode on a buffered text-mode handle, see bug - -- \#679. - bmode2 <- case ha_type of - ReadWriteHandle | not binary -> return NoBuffering - _other -> return bmode -#else - let bmode2 = bmode -#endif - - spares <- newIORef BufferListNil - newFileHandle filepath (handleFinalizer filepath) - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = bmode2, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd is_stream filepath binary = do - (w_buf, w_bmode) <- getBuffer fd WriteBuffer - w_spares <- newIORef BufferListNil - let w_handle_ = - Handle__ { haFD = fd, - haType = WriteHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = w_bmode, - haBuffer = w_buf, - haBuffers = w_spares, - haOtherSide = Nothing - } - write_side <- newMVar w_handle_ - - (r_buf, r_bmode) <- getBuffer fd ReadBuffer - r_spares <- newIORef BufferListNil - let r_handle_ = - Handle__ { haFD = fd, - haType = ReadHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = r_bmode, - haBuffer = r_buf, - haBuffers = r_spares, - haOtherSide = Just write_side - } - read_side <- newMVar r_handle_ - - addMVarFinalizer write_side (handleFinalizer filepath write_side) - return (DuplexHandle filepath read_side write_side) - -initBufferState :: HandleType -> BufferState -initBufferState ReadHandle = ReadBuffer -initBufferState _ = WriteBuffer - --- --------------------------------------------------------------------------- --- Closing a handle - --- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the --- computation finishes, if @hdl@ is writable its buffer is flushed as --- for 'hFlush'. --- Performing 'hClose' on a handle that has already been closed has no effect; --- doing so is not an error. All other operations on a closed handle will fail. --- If 'hClose' fails for any reason, any further operations (apart from --- 'hClose') on the handle will still fail as if @hdl@ had been successfully --- closed. - -hClose :: Handle -> IO () -hClose h@(FileHandle _ m) = do - mb_exc <- hClose' h m - case mb_exc of - Nothing -> return () - Just e -> throwIO e -hClose h@(DuplexHandle _ r w) = do - mb_exc1 <- hClose' h w - mb_exc2 <- hClose' h r - case (do mb_exc1; mb_exc2) of - Nothing -> return () - Just e -> throwIO e - -hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) -hClose' h m = withHandle' "hClose" h m $ hClose_help - --- hClose_help is also called by lazyRead (in PrelIO) when EOF is read --- or an IO error occurs on a lazy stream. The semi-closed Handle is --- then closed immediately. We have to be careful with DuplexHandles --- though: we have to leave the closing to the finalizer in that case, --- because the write side may still be in use. -hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException) -hClose_help handle_ = - case haType handle_ of - ClosedHandle -> return (handle_,Nothing) - _ -> do flushWriteBufferOnly handle_ -- interruptible - hClose_handle_ handle_ - -hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) -hClose_handle_ handle_ = do - let fd = haFD handle_ - - -- close the file descriptor, but not when this is the read - -- side of a duplex handle. - -- If an exception is raised by the close(), we want to continue - -- to close the handle and release the lock if it has one, then - -- we return the exception to the caller of hClose_help which can - -- raise it if necessary. - maybe_exception <- - case haOtherSide handle_ of - Nothing -> (do - throwErrnoIfMinus1Retry_ "hClose" -#ifdef mingw32_HOST_OS - (closeFd (haIsStream handle_) fd) -#else - (c_close fd) -#endif - return Nothing - ) - `catchException` \e -> return (Just e) - - Just _ -> return Nothing - - -- free the spare buffers - writeIORef (haBuffers handle_) BufferListNil - writeIORef (haBuffer handle_) noBuffer - -#ifndef mingw32_HOST_OS - -- unlock it - unlockFile fd -#endif - - -- we must set the fd to -1, because the finalizer is going - -- to run eventually and try to close/unlock it. - return (handle_{ haFD = -1, - haType = ClosedHandle - }, - maybe_exception) - -{-# NOINLINE noBuffer #-} -noBuffer :: Buffer -noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer - ------------------------------------------------------------------------------ --- Detecting and changing the size of a file - --- | For a handle @hdl@ which attached to a physical file, --- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes. - -hFileSize :: Handle -> IO Integer -hFileSize handle = - withHandle_ "hFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - r <- fdFileSize (haFD handle_) - if r /= -1 - then return r - else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing) - - --- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. - -hSetFileSize :: Handle -> Integer -> IO () -hSetFileSize handle size = - withHandle_ "hSetFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - throwErrnoIf (/=0) "hSetFileSize" - (c_ftruncate (haFD handle_) (fromIntegral size)) - return () - --- --------------------------------------------------------------------------- --- Detecting the End of Input - --- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns --- 'True' if no further input can be taken from @hdl@ or for a --- physical file, if the current I\/O position is equal to the length of --- the file. Otherwise, it returns 'False'. --- --- NOTE: 'hIsEOF' may block, because it is the same as calling --- 'hLookAhead' and checking for an EOF exception. - -hIsEOF :: Handle -> IO Bool -hIsEOF handle = - catch - (do hLookAhead handle; return False) - (\e -> if isEOFError e then return True else ioError e) - --- | The computation 'isEOF' is identical to 'hIsEOF', --- except that it works only on 'stdin'. - -isEOF :: IO Bool -isEOF = hIsEOF stdin - --- --------------------------------------------------------------------------- --- Looking ahead - --- | Computation 'hLookAhead' returns the next character from the handle --- without removing it from the input buffer, blocking until a character --- is available. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hLookAhead :: Handle -> IO Char -hLookAhead handle = - wantReadableHandle "hLookAhead" handle hLookAhead' - -hLookAhead' :: Handle__ -> IO Char -hLookAhead' handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - buf <- readIORef ref - - -- fill up the read buffer if necessary - new_buf <- if bufferEmpty buf - then fillReadBuffer fd True (haIsStream handle_) buf - else return buf - - writeIORef ref new_buf - - (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf) - return c - --- --------------------------------------------------------------------------- --- Buffering Operations - --- Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. See GHC.IOBase for definition and --- further explanation of what the type represent. - --- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for --- handle @hdl@ on subsequent reads and writes. --- --- If the buffer mode is changed from 'BlockBuffering' or --- 'LineBuffering' to 'NoBuffering', then --- --- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; --- --- * if @hdl@ is not writable, the contents of the buffer is discarded. --- --- This operation may fail with: --- --- * 'isPermissionError' if the handle has already been used for reading --- or writing and the implementation does not allow the buffering mode --- to be changed. - -hSetBuffering :: Handle -> BufferMode -> IO () -hSetBuffering handle mode = - withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> do - {- Note: - - we flush the old buffer regardless of whether - the new buffer could fit the contents of the old buffer - or not. - - allow a handle's buffering to change even if IO has - occurred (ANSI C spec. does not allow this, nor did - the previous implementation of IO.hSetBuffering). - - a non-standard extension is to allow the buffering - of semi-closed handles to change [sof 6/98] - -} - flushBuffer handle_ - - let state = initBufferState (haType handle_) - new_buf <- - case mode of - -- we always have a 1-character read buffer for - -- unbuffered handles: it's needed to - -- support hLookAhead. - NoBuffering -> allocateBuffer 1 ReadBuffer - LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n - | otherwise -> allocateBuffer n state - writeIORef (haBuffer handle_) new_buf - - -- for input terminals we need to put the terminal into - -- cooked or raw mode depending on the type of buffering. - is_tty <- fdIsTTY (haFD handle_) - when (is_tty && isReadableHandleType (haType handle_)) $ - case mode of -#ifndef mingw32_HOST_OS - -- 'raw' mode under win32 is a bit too specialised (and troublesome - -- for most common uses), so simply disable its use here. - NoBuffering -> setCooked (haFD handle_) False -#else - NoBuffering -> return () -#endif - _ -> setCooked (haFD handle_) True - - -- throw away spare buffers, they might be the wrong size - writeIORef (haBuffers handle_) BufferListNil - - return (handle_{ haBufferMode = mode }) - --- ----------------------------------------------------------------------------- --- hFlush - --- | The action 'hFlush' @hdl@ causes any items buffered for output --- in handle @hdl@ to be sent immediately to the operating system. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; --- --- * 'isPermissionError' if a system resource limit would be exceeded. --- It is unspecified whether the characters in the buffer are discarded --- or retained under these circumstances. - -hFlush :: Handle -> IO () -hFlush handle = - wantWritableHandle "hFlush" handle $ \ handle_ -> do - buf <- readIORef (haBuffer handle_) - if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef (haBuffer handle_) flushed_buf - else return () - - --- ----------------------------------------------------------------------------- --- Repositioning Handles - -data HandlePosn = HandlePosn Handle HandlePosition - -instance Eq HandlePosn where - (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 - -instance Show HandlePosn where - showsPrec p (HandlePosn h pos) = - showsPrec p h . showString " at position " . shows pos - - -- HandlePosition is the Haskell equivalent of POSIX' off_t. - -- We represent it as an Integer on the Haskell side, but - -- cheat slightly in that hGetPosn calls upon a C helper - -- that reports the position back via (merely) an Int. -type HandlePosition = Integer - --- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of --- @hdl@ as a value of the abstract type 'HandlePosn'. - -hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = do - posn <- hTell handle - return (HandlePosn handle posn) - --- | If a call to 'hGetPosn' @hdl@ returns a position @p@, --- then computation 'hSetPosn' @p@ sets the position of @hdl@ --- to the position it held at the time of the call to 'hGetPosn'. --- --- This operation may fail with: --- --- * 'isPermissionError' if a system resource limit would be exceeded. - -hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i - --- --------------------------------------------------------------------------- --- hSeek - --- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows: -data SeekMode - = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. - | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ - -- from the current position. - | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ - -- from the end of the file. - deriving (Eq, Ord, Ix, Enum, Read, Show) - -{- Note: - - when seeking using `SeekFromEnd', positive offsets (>=0) means - seeking at or past EOF. - - - we possibly deviate from the report on the issue of seeking within - the buffer and whether to flush it or not. The report isn't exactly - clear here. --} - --- | Computation 'hSeek' @hdl mode i@ sets the position of handle --- @hdl@ depending on @mode@. --- The offset @i@ is given in terms of 8-bit bytes. --- --- If @hdl@ is block- or line-buffered, then seeking to a position which is not --- in the current buffer will first cause any items in the output buffer to be --- written to the device, and then cause the input buffer to be discarded. --- Some handles may not be seekable (see 'hIsSeekable'), or only support a --- subset of the possible positioning operations (for instance, it may only --- be possible to seek to the end of a tape, or to a positive offset from --- the beginning or current position). --- It is not possible to set a negative I\/O position, or for --- a physical file, an I\/O position beyond the current end-of-file. --- --- This operation may fail with: --- --- * 'isPermissionError' if a system resource limit would be exceeded. - -hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek handle mode offset = - wantSeekableHandle "hSeek" handle $ \ handle_ -> do -# ifdef DEBUG_DUMP - puts ("hSeek " ++ show (mode,offset) ++ "\n") -# endif - let ref = haBuffer handle_ - buf <- readIORef ref - let r = bufRPtr buf - w = bufWPtr buf - fd = haFD handle_ - - let do_seek = - throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (haFD handle_) (fromIntegral offset) whence) - - whence :: CInt - whence = case mode of - AbsoluteSeek -> sEEK_SET - RelativeSeek -> sEEK_CUR - SeekFromEnd -> sEEK_END - - if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf - writeIORef ref new_buf - do_seek - else do - - if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r) - then writeIORef ref buf{ bufRPtr = r + fromIntegral offset } - else do - - new_buf <- flushReadBuffer (haFD handle_) buf - writeIORef ref new_buf - do_seek - - -hTell :: Handle -> IO Integer -hTell handle = - wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - -#if defined(mingw32_HOST_OS) - -- urgh, on Windows we have to worry about \n -> \r\n translation, - -- so we can't easily calculate the file position using the - -- current buffer size. Just flush instead. - flushBuffer handle_ -#endif - let fd = haFD handle_ - posn <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 sEEK_CUR) - - let ref = haBuffer handle_ - buf <- readIORef ref - - let real_posn - | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) - | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") - puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") -# endif - return real_posn - --- ----------------------------------------------------------------------------- --- Handle Properties - --- A number of operations return information about the properties of a --- handle. Each of these operations returns `True' if the handle has --- the specified property, and `False' otherwise. - -hIsOpen :: Handle -> IO Bool -hIsOpen handle = - withHandle_ "hIsOpen" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return False - SemiClosedHandle -> return False - _ -> return True - -hIsClosed :: Handle -> IO Bool -hIsClosed handle = - withHandle_ "hIsClosed" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return True - _ -> return False - -{- not defined, nor exported, but mentioned - here for documentation purposes: - - hSemiClosed :: Handle -> IO Bool - hSemiClosed h = do - ho <- hIsOpen h - hc <- hIsClosed h - return (not (ho || hc)) --} - -hIsReadable :: Handle -> IO Bool -hIsReadable (DuplexHandle _ _ _) = return True -hIsReadable handle = - withHandle_ "hIsReadable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isReadableHandleType htype) - -hIsWritable :: Handle -> IO Bool -hIsWritable (DuplexHandle _ _ _) = return True -hIsWritable handle = - withHandle_ "hIsWritable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isWritableHandleType htype) - --- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode --- for @hdl@. - -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering handle = - withHandle_ "hGetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> - -- We're being non-standard here, and allow the buffering - -- of a semi-closed handle to be queried. -- sof 6/98 - return (haBufferMode handle_) -- could be stricter.. - -hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = - withHandle_ "hIsSeekable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> return False - _ -> do t <- fdType (haFD handle_) - return ((t == RegularFile || t == RawDevice) - && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) - --- ----------------------------------------------------------------------------- --- Changing echo status (Non-standard GHC extensions) - --- | Set the echoing status of a handle connected to a terminal. - -hSetEcho :: Handle -> Bool -> IO () -hSetEcho handle on = do - isT <- hIsTerminalDevice handle - if not isT - then return () - else - withHandle_ "hSetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> setEcho (haFD handle_) on - --- | Get the echoing status of a handle connected to a terminal. - -hGetEcho :: Handle -> IO Bool -hGetEcho handle = do - isT <- hIsTerminalDevice handle - if not isT - then return False - else - withHandle_ "hGetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> getEcho (haFD handle_) - --- | Is the handle connected to a terminal? - -hIsTerminalDevice :: Handle -> IO Bool -hIsTerminalDevice handle = do - withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> fdIsTTY (haFD handle_) - --- ----------------------------------------------------------------------------- --- hSetBinaryMode - --- | Select binary mode ('True') or text mode ('False') on a open handle. --- (See also 'openBinaryFile'.) - -hSetBinaryMode :: Handle -> Bool -> IO () -hSetBinaryMode handle bin = - withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - do throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (haFD handle_) bin) - return handle_{haIsBin=bin} - -foreign import ccall unsafe "__hscore_setmode" - setmode :: CInt -> Bool -> IO CInt - --- ----------------------------------------------------------------------------- --- Duplicating a Handle - --- | Returns a duplicate of the original handle, with its own buffer. --- The two Handles will share a file pointer, however. The original --- handle's buffer is flushed, including discarding any input data, --- before the handle is duplicated. - -hDuplicate :: Handle -> IO Handle -hDuplicate h@(FileHandle path m) = do - new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing) - newFileHandle path (handleFinalizer path) new_h_ -hDuplicate h@(DuplexHandle path r w) = do - new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing) - new_w <- newMVar new_w_ - new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w)) - new_r <- newMVar new_r_ - addMVarFinalizer new_w (handleFinalizer path new_w) - return (DuplexHandle path new_r new_w) - -dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__ - -> IO (Handle__, Handle__) -dupHandle h other_side h_ = do - -- flush the buffer first, so we don't have to copy its contents - flushBuffer h_ - new_fd <- case other_side of - Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_) - Just r -> withHandle_' "dupHandle" h r (return . haFD) - dupHandle_ other_side h_ new_fd - -dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__ - -> IO (Handle__, Handle__) -dupHandleTo other_side hto_ h_ = do - flushBuffer h_ - -- Windows' dup2 does not return the new descriptor, unlike Unix - throwErrnoIfMinus1 "dupHandleTo" $ - c_dup2 (haFD h_) (haFD hto_) - dupHandle_ other_side h_ (haFD hto_) - -dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD - -> IO (Handle__, Handle__) -dupHandle_ other_side h_ new_fd = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_)) - ioref <- newIORef buffer - ioref_buffers <- newIORef BufferListNil - - let new_handle_ = h_{ haFD = new_fd, - haBuffer = ioref, - haBuffers = ioref_buffers, - haOtherSide = other_side } - return (h_, new_handle_) - --- ----------------------------------------------------------------------------- --- Replacing a Handle - -{- | -Makes the second handle a duplicate of the first handle. The second -handle will be closed first, if it is not already. - -This can be used to retarget the standard Handles, for example: - -> do h <- openFile "mystdout" WriteMode -> hDuplicateTo h stdout --} - -hDuplicateTo :: Handle -> Handle -> IO () -hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do - withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do - _ <- hClose_help h2_ - withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_) -hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do - withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do - _ <- hClose_help w2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_) - withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do - _ <- hClose_help r2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) -hDuplicateTo h1 _ = - ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" - "handles are incompatible" Nothing) - --- --------------------------------------------------------------------------- --- showing Handles. --- --- | 'hShow' is in the 'IO' monad, and gives more comprehensive output --- than the (pure) instance of 'Show' for 'Handle'. - -hShow :: Handle -> IO String -hShow h@(FileHandle path _) = showHandle' path False h -hShow h@(DuplexHandle path _ _) = showHandle' path True h - -showHandle' :: String -> Bool -> Handle -> IO String -showHandle' filepath is_duplex h = - withHandle_ "showHandle" h $ \hdl_ -> - let - showType | is_duplex = showString "duplex (read-write)" - | otherwise = shows (haType hdl_) - in - return - (( showChar '{' . - showHdl (haType hdl_) - (showString "loc=" . showString filepath . showChar ',' . - showString "type=" . showType . showChar ',' . - showString "binary=" . shows (haIsBin hdl_) . showChar ',' . - showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) - ) "") - where - - showHdl :: HandleType -> ShowS -> ShowS - showHdl ht cont = - case ht of - ClosedHandle -> shows ht . showString "}" - _ -> cont - - showBufMode :: Buffer -> BufferMode -> ShowS - showBufMode buf bmo = - case bmo of - NoBuffering -> showString "none" - LineBuffering -> showString "line" - BlockBuffering (Just n) -> showString "block " . showParen True (shows n) - BlockBuffering Nothing -> showString "block " . showParen True (shows def) - where - def :: Int - def = bufSize buf - --- --------------------------------------------------------------------------- --- debugging - -#if defined(DEBUG_DUMP) -puts :: String -> IO () -puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s)) - return () -#endif - --- ----------------------------------------------------------------------------- --- utils - -throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt -throwErrnoIfMinus1RetryOnBlock loc f on_block = - do - res <- f - if (res :: CInt) == -1 - then do - err <- getErrno - if err == eINTR - then throwErrnoIfMinus1RetryOnBlock loc f on_block - else if err == eWOULDBLOCK || err == eAGAIN - then do on_block - else throwErrno loc - else return res - --- ----------------------------------------------------------------------------- --- wrappers to platform-specific constants: - -foreign import ccall unsafe "__hscore_supportsTextMode" - tEXT_MODE_SEEK_ALLOWED :: Bool - -foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int -foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt -foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt -foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Handle +-- Copyright : (c) The University of Glasgow, 1994-2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Backwards-compatibility interface +-- +----------------------------------------------------------------------------- + +-- #hide + +module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle instead" #-} ( + withHandle, withHandle', withHandle_, + wantWritableHandle, wantReadableHandle, wantSeekableHandle, + +-- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, +-- flushWriteBufferOnly, flushWriteBuffer, +-- flushReadBuffer, +-- fillReadBuffer, fillReadBufferWithoutBlocking, +-- readRawBuffer, readRawBufferPtr, +-- readRawBufferNoBlock, readRawBufferPtrNoBlock, +-- writeRawBuffer, writeRawBufferPtr, + + ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, + + stdin, stdout, stderr, + IOMode(..), openFile, openBinaryFile, +-- fdToHandle_stat, + fdToHandle, fdToHandle', + hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead_, + hSetBuffering, hSetBinaryMode, + hFlush, hDuplicate, hDuplicateTo, + + hClose, hClose_help, + + HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, + SeekMode(..), hSeek, hTell, + + hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, + hSetEcho, hGetEcho, hIsTerminalDevice, + + hShow, + + ) where + +import GHC.IO.IOMode +import GHC.IO.Handle +import GHC.IO.Handle.Internals +import GHC.IO.Handle.FD diff --git a/lib/base/src/GHC/Handle.hs-boot b/lib/base/src/GHC/Handle.hs-boot deleted file mode 100644 --- a/lib/base/src/GHC/Handle.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module GHC.Handle where - -import GHC.IOBase - -stdout :: Handle -stderr :: Handle -hFlush :: Handle -> IO () diff --git a/lib/base/src/GHC/IO.hs b/lib/base/src/GHC/IO.hs --- a/lib/base/src/GHC/IO.hs +++ b/lib/base/src/GHC/IO.hs @@ -1,974 +1,342 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} -{-# OPTIONS_HADDOCK hide #-} - -#undef DEBUG_DUMP - ------------------------------------------------------------------------------ --- | --- Module : GHC.IO --- Copyright : (c) The University of Glasgow, 1992-2001 --- License : see libraries/base/LICENSE --- --- Maintainer : libraries@haskell.org --- Stability : internal --- Portability : non-portable --- --- String I\/O functions --- ------------------------------------------------------------------------------ - --- #hide -module GHC.IO ( - hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, - commitBuffer', -- hack, see below - hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs - hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile, - memcpy_ba_baoff, - memcpy_ptr_baoff, - memcpy_baoff_ba, - memcpy_baoff_ptr, - ) where - -import Foreign -import Foreign.C - -import System.IO.Error -import Data.Maybe -import Control.Monad -#ifndef mingw32_HOST_OS -import System.Posix.Internals -#endif - -import GHC.Enum -import GHC.Base -import GHC.IOBase -import GHC.Handle -- much of the real stuff is in here -import GHC.Real -import GHC.Num -import GHC.Show -import GHC.List - -#ifdef mingw32_HOST_OS -import GHC.Conc -#endif - --- --------------------------------------------------------------------------- --- Simple input operations - --- If hWaitForInput finds anything in the Handle's buffer, it --- immediately returns. If not, it tries to read from the underlying --- OS handle. Notice that for buffered Handles connected to terminals --- this means waiting until a complete line is available. - --- | Computation 'hWaitForInput' @hdl t@ --- waits until input is available on handle @hdl@. --- It returns 'True' as soon as input is available on @hdl@, --- or 'False' if no input is available within @t@ milliseconds. --- --- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. --- --- NOTE for GHC users: unless you use the @-threaded@ flag, --- @hWaitForInput t@ where @t >= 0@ will block all other Haskell --- threads for the duration of the call. It behaves like a --- @safe@ foreign call in this respect. - -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput h msecs = do - wantReadableHandle "hWaitForInput" h $ \ handle_ -> do - let ref = haBuffer handle_ - buf <- readIORef ref - - if not (bufferEmpty buf) - then return True - else do - - if msecs < 0 - then do buf' <- fillReadBuffer (haFD handle_) True - (haIsStream handle_) buf - writeIORef ref buf' - return True - else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $ - fdReady (haFD handle_) 0 {- read -} - (fromIntegral msecs) - (fromIntegral $ fromEnum $ haIsStream handle_) - if r /= 0 then do -- Call hLookAhead' to throw an EOF - -- exception if appropriate - hLookAhead' handle_ - return True - else return False - -foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt - --- --------------------------------------------------------------------------- --- hGetChar - --- | Computation 'hGetChar' @hdl@ reads a character from the file or --- channel managed by @hdl@, blocking until a character is available. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetChar :: Handle -> IO Char -hGetChar handle = - wantReadableHandle "hGetChar" handle $ \handle_ -> do - - let fd = haFD handle_ - ref = haBuffer handle_ - - buf <- readIORef ref - if not (bufferEmpty buf) - then hGetcBuffered fd ref buf - else do - - -- buffer is empty. - case haBufferMode handle_ of - LineBuffering -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - hGetcBuffered fd ref new_buf - BlockBuffering _ -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - -- ^^^^ - -- don't wait for a completely full buffer. - hGetcBuffered fd ref new_buf - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1 - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char -hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w } - = do (c, r) <- readCharFromBuffer b r0 - let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } - writeIORef ref new_buf - return c - --- --------------------------------------------------------------------------- --- hGetLine - --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. - --- | Computation 'hGetLine' @hdl@ reads a line from the file or --- channel managed by @hdl@. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file is encountered when reading --- the /first/ character of the line. --- --- If 'hGetLine' encounters end-of-file at any other point while reading --- in a line, it is treated as a line terminator and the (partial) --- line is returned. - -hGetLine :: Handle -> IO String -hGetLine h = do - m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> return Nothing - LineBuffering -> do - l <- hGetLineBuffered handle_ - return (Just l) - BlockBuffering _ -> do - l <- hGetLineBuffered handle_ - return (Just l) - case m of - Nothing -> hGetLineUnBuffered h - Just l -> return l - -hGetLineBuffered :: Handle__ -> IO String -hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf [] - -hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String] - -> IO String -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss = - let - -- find the end-of-line character, if there is one - loop raw r - | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return (True, r) -- NB. not r': don't include the '\n' - else loop raw r' - in do - (eol, off) <- loop raw0 r0 - -#ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") -#endif - - xs <- unpack raw0 r0 off - - -- if eol == True, then off is the offset of the '\n' - -- otherwise off == w and the buffer is now empty. - if eol - then do if (w == off + 1) - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } - return (concat (reverse (xs:xss))) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> do - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - let str = concat (reverse (xs:xss)) - if not (null str) - then return str - else ioe_EOF - Just new_buf -> - hGetLineBufferedLoop handle_ ref new_buf (xs:xss) - -maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer) -maybeFillReadBuffer fd is_line is_stream buf - = catch - (do buf' <- fillReadBuffer fd is_line is_stream buf - return (Just buf') - ) - (\e -> do if isEOFError e - then return Nothing - else ioError e) - - -unpack :: RawBuffer -> Int -> Int -> IO [Char] -unpack _ _ 0 = return "" -unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s - where - unpackRB acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' - - -hGetLineUnBuffered :: Handle -> IO String -hGetLineUnBuffered h = do - c <- hGetChar h - if c == '\n' then - return "" - else do - l <- getRest - return (c:l) - where - getRest = do - c <- - catch - (hGetChar h) - (\ err -> do - if isEOFError err then - return '\n' - else - ioError err) - if c == '\n' then - return "" - else do - s <- getRest - return (c:s) - --- ----------------------------------------------------------------------------- --- hGetContents - --- hGetContents on a DuplexHandle only affects the read side: you can --- carry on writing to it afterwards. - --- | Computation 'hGetContents' @hdl@ returns the list of characters --- corresponding to the unread portion of the channel or file managed --- by @hdl@, which is put into an intermediate state, /semi-closed/. --- In this state, @hdl@ is effectively closed, --- but items are read from @hdl@ on demand and accumulated in a special --- list returned by 'hGetContents' @hdl@. --- --- Any operation that fails because a handle is closed, --- also fails if a handle is semi-closed. The only exception is 'hClose'. --- A semi-closed handle becomes closed: --- --- * if 'hClose' is applied to it; --- --- * if an I\/O error occurs when reading an item from the handle; --- --- * or once the entire contents of the handle has been read. --- --- Once a semi-closed handle becomes closed, the contents of the --- associated list becomes fixed. The contents of this final list is --- only partially specified: it will contain at least all the items of --- the stream that were evaluated prior to the handle becoming closed. --- --- Any I\/O errors encountered while a handle is semi-closed are simply --- discarded. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetContents :: Handle -> IO String -hGetContents handle = - withHandle "hGetContents" handle $ \handle_ -> - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - _ -> do xs <- lazyRead handle - return (handle_{ haType=SemiClosedHandle}, xs ) - --- Note that someone may close the semi-closed handle (or change its --- buffering), so each time these lazy read functions are pulled on, --- they have to check whether the handle has indeed been closed. - -lazyRead :: Handle -> IO String -lazyRead handle = - unsafeInterleaveIO $ - withHandle "lazyRead" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return (handle_, "") - SemiClosedHandle -> lazyRead' handle handle_ - _ -> ioException - (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing) - -lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) -lazyRead' h handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - - -- even a NoBuffering handle can have a char in the buffer... - -- (see hLookAhead) - buf <- readIORef ref - if not (bufferEmpty buf) - then lazyReadHaveBuffer h handle_ fd ref buf - else do - - case haBufferMode handle_ of - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1 - if r == 0 - then do (handle_', _) <- hClose_help handle_ - return (handle_', "") - else do (c,_) <- readCharFromBuffer raw 0 - rest <- lazyRead h - return (handle_, c : rest) - - LineBuffering -> lazyReadBuffered h handle_ fd ref buf - BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf - --- we never want to block during the read, so we call fillReadBuffer with --- is_line==True, which tells it to "just read what there is". -lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer - -> IO (Handle__, [Char]) -lazyReadBuffered h handle_ fd ref buf = do - catch - (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf - lazyReadHaveBuffer h handle_ fd ref buf' - ) - -- all I/O errors are discarded. Additionally, we close the handle. - (\_ -> do (handle_', _) <- hClose_help handle_ - return (handle_', "") - ) - -lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char]) -lazyReadHaveBuffer h handle_ _ ref buf = do - more <- lazyRead h - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more - return (handle_, s) - - -unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] -unpackAcc _ _ 0 acc = return acc -unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s - where - unpackRB acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' - --- --------------------------------------------------------------------------- --- hPutChar - --- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the --- file or channel managed by @hdl@. Characters may be buffered if --- buffering is enabled for @hdl@. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; or --- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutChar :: Handle -> Char -> IO () -hPutChar handle c = do - c `seq` return () - wantWritableHandle "hPutChar" handle $ \ handle_ -> do - let fd = haFD handle_ - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - with (castCharToCChar c) $ \buf -> do - writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1 - return () - -hPutcBuffered :: Handle__ -> Bool -> Char -> IO () -hPutcBuffered handle_ is_line c = do - let ref = haBuffer handle_ - buf <- readIORef ref - let w = bufWPtr buf - w' <- writeCharIntoBuffer (bufBuf buf) w c - let new_buf = buf{ bufWPtr = w' } - if bufferFull new_buf || is_line && c == '\n' - then do - flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf - writeIORef ref flushed_buf - else do - writeIORef ref new_buf - - -hPutChars :: Handle -> [Char] -> IO () -hPutChars _ [] = return () -hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs - --- --------------------------------------------------------------------------- --- hPutStr - --- We go to some trouble to avoid keeping the handle locked while we're --- evaluating the string argument to hPutStr, in case doing so triggers another --- I/O operation on the same handle which would lead to deadlock. The classic --- case is --- --- putStr (trace "hello" "world") --- --- so the basic scheme is this: --- --- * copy the string into a fresh buffer, --- * "commit" the buffer to the handle. --- --- Committing may involve simply copying the contents of the new --- buffer into the handle's buffer, flushing one or both buffers, or --- maybe just swapping the buffers over (if the handle's buffer was --- empty). See commitBuffer below. - --- | Computation 'hPutStr' @hdl s@ writes the string --- @s@ to the file or channel managed by @hdl@. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; or --- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - buffer_mode <- wantWritableHandle "hPutStr" handle - (\ handle_ -> do getSpareBuffer handle_) - case buffer_mode of - (NoBuffering, _) -> do - hPutChars handle str -- v. slow, but we don't care - (LineBuffering, buf) -> do - writeLines handle buf str - (BlockBuffering _, buf) -> do - writeBlocks handle buf str - - -getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer) -getSpareBuffer Handle__{haBuffer=ref, - haBuffers=spare_ref, - haBufferMode=mode} - = do - case mode of - NoBuffering -> return (mode, error "no buffer!") - _ -> do - bufs <- readIORef spare_ref - buf <- readIORef ref - case bufs of - BufferListCons b rest -> do - writeIORef spare_ref rest - return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) - BufferListNil -> do - new_buf <- allocateBuffer (bufSize buf) WriteBuffer - return (mode, new_buf) - - -writeLines :: Handle -> Buffer -> String -> IO () -writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeLines hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - if (c == '\n') - then do - new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False - writeLines hdl new_buf cs - else - shoveString n' cs - in - shoveString 0 s - -writeBlocks :: Handle -> Buffer -> String -> IO () -writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeBlocks hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - shoveString n' cs - in - shoveString 0 s - --- ----------------------------------------------------------------------------- --- commitBuffer handle buf sz count flush release --- --- Write the contents of the buffer 'buf' ('sz' bytes long, containing --- 'count' bytes of data) to handle (handle must be block or line buffered). --- --- Implementation: --- --- for block/line buffering, --- 1. If there isn't room in the handle buffer, flush the handle --- buffer. --- --- 2. If the handle buffer is empty, --- if flush, --- then write buf directly to the device. --- else swap the handle buffer with buf. --- --- 3. If the handle buffer is non-empty, copy buf into the --- handle buffer. Then, if flush != 0, flush --- the buffer. - -commitBuffer - :: Handle -- handle to commit to - -> RawBuffer -> Int -- address and size (in bytes) of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- True <=> flush the handle afterward - -> Bool -- release the buffer? - -> IO Buffer - -commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do - wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' raw sz count flush release - --- Explicitly lambda-lift this function to subvert GHC's full laziness --- optimisations, which otherwise tends to float out subexpressions --- past the \handle, which is really a pessimisation in this case because --- that lambda is a one-shot lambda. --- --- Don't forget to export the function, to stop it being inlined too --- (this appears to be better than NOINLINE, because the strictness --- analyser still gets to worker-wrapper it). --- --- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 --- -commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__ - -> IO Buffer -commitBuffer' raw sz@(I# _) count@(I# _) flush release - handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do - -#ifdef DEBUG_DUMP - puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count - ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") -#endif - - old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size } - <- readIORef ref - - buf_ret <- - -- enough room in handle buffer? - if (not flush && (size - w > count)) - -- The > is to be sure that we never exactly fill - -- up the buffer, which would require a flush. So - -- if copying the new data into the buffer would - -- make the buffer full, we just flush the existing - -- buffer and the new data immediately, rather than - -- copying before flushing. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return (newEmptyBuffer raw WriteBuffer sz) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf - - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=sz } - - -- if: (a) we don't have to flush, and - -- (b) size(new buffer) == size(old buffer), and - -- (c) new buffer is not full, - -- we can just just swap them over... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - flushWriteBuffer fd (haIsStream handle_) this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (newEmptyBuffer raw WriteBuffer sz) - else allocateBuffer size WriteBuffer - - -- release the buffer if necessary - case buf_ret of - Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do - if release && buf_ret_sz == size - then do - spare_bufs <- readIORef spare_buf_ref - writeIORef spare_buf_ref - (BufferListCons buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret - --- --------------------------------------------------------------------------- --- Reading/writing sequences of bytes. - --- --------------------------------------------------------------------------- --- hPutBuf - --- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the --- buffer @buf@ to the handle @hdl@. It returns (). --- --- This operation may fail with: --- --- * 'ResourceVanished' if the handle is a pipe or socket, and the --- reading end is closed. (If this is a POSIX system, and the program --- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered --- instead, whose default action is to terminate the program). - -hPutBuf :: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> IO () -hPutBuf h ptr count = do hPutBuf' h ptr count True; return () - -hPutBufNonBlocking - :: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> IO Int -- returns: number of bytes written -hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False - -hPutBuf':: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- allow blocking? - -> IO Int -hPutBuf' handle ptr count can_block - | count == 0 = return 0 - | count < 0 = illegalBufferSize handle "hPutBuf" count - | otherwise = - wantWritableHandle "hPutBuf" handle $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> - bufWrite fd ref is_stream ptr count can_block - -bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int -bufWrite fd ref is_stream ptr count can_block = - seq count $ seq fd $ do -- strictness hack - old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size } - <- readIORef ref - - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return count - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd is_stream old_buf - -- TODO: we should do a non-blocking flush here - writeIORef ref flushed_buf - -- if we can fit in the buffer, then just loop - if count < size - then bufWrite fd ref is_stream ptr count can_block - else if can_block - then do writeChunk fd is_stream (castPtr ptr) count - return count - else writeChunkNonBlocking fd is_stream ptr count - -writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO () -writeChunk fd is_stream ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO () - loop _ bytes | bytes <= 0 = return () - loop off bytes = do - r <- fromIntegral `liftM` - writeRawBufferPtr "writeChunk" fd is_stream ptr - off (fromIntegral bytes) - -- write can't return 0 - loop (off + r) (bytes - r) - -writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -writeChunkNonBlocking fd -#ifndef mingw32_HOST_OS - _ -#else - is_stream -#endif - ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do -#ifndef mingw32_HOST_OS - ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes) - let r = fromIntegral ssize :: Int - if (r == -1) - then do errno <- getErrno - if (errno == eAGAIN || errno == eWOULDBLOCK) - then return off - else throwErrno "writeChunk" - else loop (off + r) (bytes - r) -#else - (ssize, rc) <- asyncWrite (fromIntegral fd) - (fromIntegral $ fromEnum is_stream) - (fromIntegral bytes) - (ptr `plusPtr` off) - let r = fromIntegral ssize :: Int - if r == (-1) - then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing) - else loop (off + r) (bytes - r) -#endif - --- --------------------------------------------------------------------------- --- hGetBuf - --- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@ --- into the buffer @buf@ until either EOF is reached or --- @count@ 8-bit bytes have been read. --- It returns the number of bytes actually read. This may be zero if --- EOF was reached before any data was read (or if @count@ is zero). --- --- 'hGetBuf' never raises an EOF exception, instead it returns a value --- smaller than @count@. --- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGetBuf' will behave as if EOF was reached. - -hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count - | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBuf" count - | otherwise = - wantReadableHandle "hGetBuf" h $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufRead fd ref is_stream ptr 0 count - --- small reads go through the buffer, large reads are satisfied by --- taking data first from the buffer and then direct from the file --- descriptor. -bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int -bufRead fd ref is_stream ptr so_far count = - seq fd $ seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref - if bufferEmpty buf - then if count > sz -- small read? - then do rest <- readChunk fd is_stream ptr count - return (so_far + rest) - else do mb_buf <- maybeFillReadBuffer fd True is_stream buf - case mb_buf of - Nothing -> return so_far -- got nothing, we're done - Just buf' -> do - writeIORef ref buf' - bufRead fd ref is_stream ptr so_far count - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return (so_far + count) - else do - if (count < avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - let remaining = count - avail - so_far' = so_far + avail - ptr' = ptr `plusPtr` avail - - if remaining < sz - then bufRead fd ref is_stream ptr' so_far' remaining - else do - - rest <- readChunk fd is_stream ptr' remaining - return (so_far' + rest) - -readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunk fd is_stream ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do - r <- fromIntegral `liftM` - readRawBufferPtr "readChunk" fd is_stream - (castPtr ptr) off (fromIntegral bytes) - if r == 0 - then return off - else loop (off + r) (bytes - r) - - --- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ --- into the buffer @buf@ until either EOF is reached, or --- @count@ 8-bit bytes have been read, or there is no more data available --- to read immediately. --- --- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will --- never block waiting for data to become available, instead it returns --- only whatever data is available. To wait for data to arrive before --- calling 'hGetBufNonBlocking', use 'hWaitForInput'. --- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. --- -hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count - | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count - | otherwise = - wantReadableHandle "hGetBufNonBlocking" h $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufReadNonBlocking fd ref is_stream ptr 0 count - -bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int - -> IO Int -bufReadNonBlocking fd ref is_stream ptr so_far count = - seq fd $ seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref - if bufferEmpty buf - then if count > sz -- large read? - then do rest <- readChunkNonBlocking fd is_stream ptr count - return (so_far + rest) - else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf - case buf' of { Buffer{ bufWPtr=w' } -> - if (w' == 0) - then return so_far - else do writeIORef ref buf' - bufReadNonBlocking fd ref is_stream ptr - so_far (min count w') - -- NOTE: new count is min count w' - -- so we will just copy the contents of the - -- buffer in the recursive call, and not - -- loop again. - } - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return (so_far + count) - else do - if (count < avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - let remaining = count - avail - so_far' = so_far + avail - ptr' = ptr `plusPtr` avail - - -- we haven't attempted to read anything yet if we get to here. - if remaining < sz - then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining - else do - - rest <- readChunkNonBlocking fd is_stream ptr' remaining - return (so_far' + rest) - - -readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunkNonBlocking fd is_stream ptr bytes = do - fromIntegral `liftM` - readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream - (castPtr ptr) 0 (fromIntegral bytes) - - -- we don't have non-blocking read support on Windows, so just invoke - -- the ordinary low-level read which will block until data is available, - -- but won't wait for the whole buffer to fill. - -slurpFile :: FilePath -> IO (Ptr (), Int) -slurpFile fname = do - handle <- openFile fname ReadMode - sz <- hFileSize handle - if sz > fromIntegral (maxBound::Int) then - ioError (userError "slurpFile: file too big") - else do - let sz_i = fromIntegral sz - if sz_i == 0 then return (nullPtr, 0) else do - chunk <- mallocBytes sz_i - r <- hGetBuf handle chunk sz_i - hClose handle - return (chunk, r) - --- --------------------------------------------------------------------------- --- memcpy wrappers - -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ()) - ------------------------------------------------------------------------------ --- Internal Utils - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 sz []) - Nothing) +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -XBangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO +-- Copyright : (c) The University of Glasgow 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Definitions for the 'IO' monad and its friends. +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO ( + IO(..), unIO, failIO, liftIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- To and from from ST + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, + + FilePath, + + catchException, catchAny, throwIO, + block, unblock, blocked, + onException, finally, evaluate + ) where + +import GHC.Base +import GHC.ST +import GHC.Exception +import Data.Maybe + +import {-# SOURCE #-} GHC.IO.Exception ( userError ) + +-- --------------------------------------------------------------------------- +-- The IO Monad + +{- +The IO Monad is just an instance of the ST monad, where the state is +the real world. We use the exception mechanism (in GHC.Exception) to +implement IO exceptions. + +NOTE: The IO representation is deeply wired in to various parts of the +system. The following list may or may not be exhaustive: + +Compiler - types of various primitives in PrimOp.lhs + +RTS - forceIO (StgMiscClosures.hc) + - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast + (Exceptions.hc) + - raiseAsync (Schedule.c) + +Prelude - GHC.IO.lhs, and several other places including + GHC.Exception.lhs. + +Libraries - parts of hslibs/lang. + +--SDM +-} + +liftIO :: IO a -> State# RealWorld -> STret RealWorld a +liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r + +failIO :: String -> IO a +failIO s = IO (raiseIO# (toException (userError s))) + +-- --------------------------------------------------------------------------- +-- Coercions between IO and ST + +-- | A monad transformer embedding strict state transformers in the 'IO' +-- monad. The 'RealWorld' parameter indicates that the internal state +-- used by the 'ST' computation is a special one supplied by the 'IO' +-- monad, and thus distinct from those used by invocations of 'runST'. +stToIO :: ST RealWorld a -> IO a +stToIO (ST m) = IO m + +ioToST :: IO a -> ST RealWorld a +ioToST (IO m) = (ST m) + +-- This relies on IO and ST having the same representation modulo the +-- constraint on the type of the state +-- +unsafeIOToST :: IO a -> ST s a +unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s + +unsafeSTToIO :: ST s a -> IO a +unsafeSTToIO (ST m) = IO (unsafeCoerce# m) + +-- --------------------------------------------------------------------------- +-- Unsafe IO operations + +{-| +This is the \"back door\" into the 'IO' monad, allowing +'IO' computation to be performed at any time. For +this to be safe, the 'IO' computation should be +free of side effects and independent of its environment. + +If the I\/O computation wrapped in 'unsafePerformIO' performs side +effects, then the relative order in which those side effects take +place (relative to the main I\/O trunk, or other calls to +'unsafePerformIO') is indeterminate. Furthermore, when using +'unsafePerformIO' to cause side-effects, you should take the following +precautions to ensure the side effects are performed as many times as +you expect them to be. Note that these precautions are necessary for +GHC, but may not be sufficient, and other compilers may require +different precautions: + + * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ + that calls 'unsafePerformIO'. If the call is inlined, + the I\/O may be performed more than once. + + * Use the compiler flag @-fno-cse@ to prevent common sub-expression + elimination being performed on the module, which might combine + two side effects that were meant to be separate. A good example + is using multiple global variables (like @test@ in the example below). + + * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the + call to 'unsafePerformIO' cannot float outside a lambda. For example, + if you say: + @ + f x = unsafePerformIO (newIORef []) + @ + you may get only one reference cell shared between all calls to @f@. + Better would be + @ + f x = unsafePerformIO (newIORef [x]) + @ + because now it can't float outside the lambda. + +It is less well known that +'unsafePerformIO' is not type safe. For example: + +> test :: IORef [a] +> test = unsafePerformIO $ newIORef [] +> +> main = do +> writeIORef test [42] +> bang <- readIORef test +> print (bang :: [Char]) + +This program will core dump. This problem with polymorphic references +is well known in the ML community, and does not arise with normal +monadic use of references. There is no easy way to make it impossible +once you use 'unsafePerformIO'. Indeed, it is +possible to write @coerce :: a -> b@ with the +help of 'unsafePerformIO'. So be careful! +-} +unsafePerformIO :: IO a -> a +unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) + +{-| +This version of 'unsafePerformIO' is slightly more efficient, +because it omits the check that the IO is only being performed by a +single thread. Hence, when you write 'unsafeDupablePerformIO', +there is a possibility that the IO action may be performed multiple +times (on a multiprocessor), and you should therefore ensure that +it gives the same results each time. +-} +{-# NOINLINE unsafeDupablePerformIO #-} +unsafeDupablePerformIO :: IO a -> a +unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) + +-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with +-- GHC.ST.runST. Essentially the issue is that the IO computation +-- inside unsafePerformIO must be atomic: it must either all run, or +-- not at all. If we let the compiler see the application of the IO +-- to realWorld#, it might float out part of the IO. + +-- Why is there a call to 'lazy' in unsafeDupablePerformIO? +-- If we don't have it, the demand analyser discovers the following strictness +-- for unsafeDupablePerformIO: C(U(AV)) +-- But then consider +-- unsafeDupablePerformIO (\s -> let r = f x in +-- case writeIORef v r s of (# s1, _ #) -> +-- (# s1, r #) +-- The strictness analyser will find that the binding for r is strict, +-- (becuase of uPIO's strictness sig), and so it'll evaluate it before +-- doing the writeIORef. This actually makes tests/lib/should_run/memo002 +-- get a deadlock! +-- +-- Solution: don't expose the strictness of unsafeDupablePerformIO, +-- by hiding it with 'lazy' + +{-| +'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily. +When passed a value of type @IO a@, the 'IO' will only be performed +when the value of the @a@ is demanded. This is used to implement lazy +file reading, see 'System.IO.hGetContents'. +-} +{-# INLINE unsafeInterleaveIO #-} +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) + +-- We believe that INLINE on unsafeInterleaveIO is safe, because the +-- state from this IO thread is passed explicitly to the interleaved +-- IO, so it cannot be floated out and shared. + +{-# INLINE unsafeDupableInterleaveIO #-} +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) + +{-| +Ensures that the suspensions under evaluation by the current thread +are unique; that is, the current thread is not evaluating anything +that is also under evaluation by another thread that has also executed +'noDuplicate'. + +This operation is used in the definition of 'unsafePerformIO' to +prevent the IO action from being executed multiple times, which is usually +undesirable. +-} +noDuplicate :: IO () +noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) + +-- ----------------------------------------------------------------------------- +-- | File and directory names are values of type 'String', whose precise +-- meaning is operating system dependent. Files can be opened, yielding a +-- handle which can then be used to operate on the contents of that file. + +type FilePath = String + +-- ----------------------------------------------------------------------------- +-- Primitive catch and throwIO + +{- +catchException used to handle the passing around of the state to the +action and the handler. This turned out to be a bad idea - it meant +that we had to wrap both arguments in thunks so they could be entered +as normal (remember IO returns an unboxed pair...). + +Now catch# has type + + catch# :: IO a -> (b -> IO a) -> IO a + +(well almost; the compiler doesn't know about the IO newtype so we +have to work around that in the definition of catchException below). +-} + +catchException :: Exception e => IO a -> (e -> IO a) -> IO a +catchException (IO io) handler = IO $ catch# io handler' + where handler' e = case fromException e of + Just e' -> unIO (handler e') + Nothing -> raise# e + +catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a +catchAny (IO io) handler = IO $ catch# io handler' + where handler' (SomeException e) = unIO (handler e) + +-- | A variant of 'throw' that can only be used within the 'IO' monad. +-- +-- Although 'throwIO' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwIO e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwIO' will only cause +-- an exception to be raised when it is used within the 'IO' monad. +-- The 'throwIO' variant should be used in preference to 'throw' to +-- raise an exception within the 'IO' monad because it guarantees +-- ordering with respect to other 'IO' operations, whereas 'throw' +-- does not. +throwIO :: Exception e => e -> IO a +throwIO e = IO (raiseIO# (toException e)) + +-- ----------------------------------------------------------------------------- +-- Controlling asynchronous exception delivery + +-- | Applying 'block' to a computation will +-- execute that computation with asynchronous exceptions +-- /blocked/. That is, any thread which +-- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be +-- blocked until asynchronous exceptions are enabled again. There\'s +-- no need to worry about re-enabling asynchronous exceptions; that is +-- done automatically on exiting the scope of +-- 'block'. +-- +-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked +-- state from the parent; that is, to start a thread in blocked mode, +-- use @block $ forkIO ...@. This is particularly useful if you need to +-- establish an exception handler in the forked thread before any +-- asynchronous exceptions are received. +block :: IO a -> IO a + +-- | To re-enable asynchronous exceptions inside the scope of +-- 'block', 'unblock' can be +-- used. It scopes in exactly the same way, so on exit from +-- 'unblock' asynchronous exception delivery will +-- be disabled again. +unblock :: IO a -> IO a + +block (IO io) = IO $ blockAsyncExceptions# io +unblock (IO io) = IO $ unblockAsyncExceptions# io + +-- | returns True if asynchronous exceptions are blocked in the +-- current thread. +blocked :: IO Bool +blocked = IO $ \s -> case asyncExceptionsBlocked# s of + (# s', i #) -> (# s', i /=# 0# #) + +onException :: IO a -> IO b -> IO a +onException io what = io `catchException` \e -> do _ <- what + throw (e :: SomeException) + +finally :: IO a -- ^ computation to run first + -> IO b -- ^ computation to run afterward (even if an exception + -- was raised) + -> IO a -- returns the value from the first computation +a `finally` sequel = + block (do + r <- unblock a `onException` sequel + _ <- sequel + return r + ) + +-- | Forces its argument to be evaluated to weak head normal form when +-- the resultant 'IO' action is executed. It can be used to order +-- evaluation with respect to other 'IO' operations; its semantics are +-- given by +-- +-- > evaluate x `seq` y ==> y +-- > evaluate x `catch` f ==> (return $! x) `catch` f +-- > evaluate x >>= f ==> (return $! x) >>= f +-- +-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the +-- same as @(return $! x)@. A correct definition is +-- +-- > evaluate x = (return $! x) >>= return +-- +evaluate :: a -> IO a +evaluate a = IO $ \s -> let !va = a in (# s, va #) -- NB. see #2273 diff --git a/lib/base/src/GHC/IO.hs-boot b/lib/base/src/GHC/IO.hs-boot new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO.hs-boot @@ -0,0 +1,5 @@ +module GHC.IO where + +import GHC.Types + +failIO :: [Char] -> IO a diff --git a/lib/base/src/GHC/IO/Buffer.hs b/lib/base/src/GHC/IO/Buffer.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Buffer.hs @@ -0,0 +1,287 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Buffer +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Buffers used in the IO system +-- +----------------------------------------------------------------------------- + +module GHC.IO.Buffer ( + -- * Buffers of any element + Buffer(..), BufferState(..), CharBuffer, CharBufElem, + + -- ** Creation + newByteBuffer, + newCharBuffer, + newBuffer, + emptyBuffer, + + -- ** Insertion/removal + bufferRemove, + bufferAdd, + slideContents, + bufferAdjustL, + + -- ** Inspecting + isEmptyBuffer, + isFullBuffer, + isFullCharBuffer, + isWriteBuffer, + bufferElems, + bufferAvailable, + summaryBuffer, + + -- ** Operating on the raw buffer as a Ptr + withBuffer, + withRawBuffer, + + -- ** Assertions + checkBuffer, + + -- * Raw buffers + RawBuffer, + readWord8Buf, + writeWord8Buf, + RawCharBuffer, + peekCharBuf, + readCharBuf, + writeCharBuf, + readCharBufPtr, + writeCharBufPtr, + charSize, + ) where + +import GHC.Base +-- import GHC.IO +import GHC.Num +import GHC.Ptr +import GHC.Word +import GHC.Show +import GHC.Real +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Storable + +-- Char buffers use either UTF-16 or UTF-32, with the endianness matching +-- the endianness of the host. +-- +-- Invariants: +-- * a Char buffer consists of *valid* UTF-16 or UTF-32 +-- * only whole characters: no partial surrogate pairs + +#define CHARBUF_UTF32 + +-- #define CHARBUF_UTF16 +-- +-- NB. it won't work to just change this to CHARBUF_UTF16. Some of +-- the code to make this work is there, and it has been tested with +-- the Iconv codec, but there are some pieces that are known to be +-- broken. In particular, the built-in codecs +-- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or +-- similar in place of the ow >= os comparisions. + +-- --------------------------------------------------------------------------- +-- Raw blocks of data + +type RawBuffer e = ForeignPtr e + +readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8 +readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix + +writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO () +writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w + +#ifdef CHARBUF_UTF16 +type CharBufElem = Word16 +#else +type CharBufElem = Char +#endif + +type RawCharBuffer = RawBuffer CharBufElem + +peekCharBuf :: RawCharBuffer -> Int -> IO Char +peekCharBuf arr ix = withForeignPtr arr $ \p -> do + (c,_) <- readCharBufPtr p ix + return c + +{-# INLINE readCharBuf #-} +readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int) +readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix + +{-# INLINE writeCharBuf #-} +writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int +writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c + +{-# INLINE readCharBufPtr #-} +readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int) +#ifdef CHARBUF_UTF16 +readCharBufPtr p ix = do + c1 <- peekElemOff p ix + if (c1 < 0xd800 || c1 > 0xdbff) + then return (chr (fromIntegral c1), ix+1) + else do c2 <- peekElemOff p (ix+1) + return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 + + (fromIntegral c2 - 0xdc00) + 0x10000), ix+2) +#else +readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1) +#endif + +{-# INLINE writeCharBufPtr #-} +writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int +#ifdef CHARBUF_UTF16 +writeCharBufPtr p ix ch + | c < 0x10000 = do pokeElemOff p ix (fromIntegral c) + return (ix+1) + | otherwise = do let c' = c - 0x10000 + pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800)) + pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00)) + return (ix+2) + where + c = ord ch +#else +writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1) +#endif + +charSize :: Int +#ifdef CHARBUF_UTF16 +charSize = 2 +#else +charSize = 4 +#endif + +-- --------------------------------------------------------------------------- +-- Buffers + +-- | A mutable array of bytes that can be passed to foreign functions. +-- +-- The buffer is represented by a record, where the record contains +-- the raw buffer and the start/end points of the filled portion. The +-- buffer contents itself is mutable, but the rest of the record is +-- immutable. This is a slightly odd mix, but it turns out to be +-- quite practical: by making all the buffer metadata immutable, we +-- can have operations on buffer metadata outside of the IO monad. +-- +-- The "live" elements of the buffer are those between the 'bufL' and +-- 'bufR' offsets. In an empty buffer, 'bufL' is equal to 'bufR', but +-- they might not be zero: for exmaple, the buffer might correspond to +-- a memory-mapped file and in which case 'bufL' will point to the +-- next location to be written, which is not necessarily the beginning +-- of the file. +data Buffer e + = Buffer { + bufRaw :: !(RawBuffer e), + bufState :: BufferState, + bufSize :: !Int, -- in elements, not bytes + bufL :: !Int, -- offset of first item in the buffer + bufR :: !Int -- offset of last item + 1 + } + +#ifdef CHARBUF_UTF16 +type CharBuffer = Buffer Word16 +#else +type CharBuffer = Buffer Char +#endif + +data BufferState = ReadBuffer | WriteBuffer deriving (Eq) + +withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a +withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f + +withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a +withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f + +isEmptyBuffer :: Buffer e -> Bool +isEmptyBuffer Buffer{ bufL=l, bufR=r } = l == r + +isFullBuffer :: Buffer e -> Bool +isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w + +-- if a Char buffer does not have room for a surrogate pair, it is "full" +isFullCharBuffer :: Buffer e -> Bool +#ifdef CHARBUF_UTF16 +isFullCharBuffer buf = bufferAvailable buf < 2 +#else +isFullCharBuffer = isFullBuffer +#endif + +isWriteBuffer :: Buffer e -> Bool +isWriteBuffer buf = case bufState buf of + WriteBuffer -> True + ReadBuffer -> False + +bufferElems :: Buffer e -> Int +bufferElems Buffer{ bufR=w, bufL=r } = w - r + +bufferAvailable :: Buffer e -> Int +bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w + +bufferRemove :: Int -> Buffer e -> Buffer e +bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf + +bufferAdjustL :: Int -> Buffer e -> Buffer e +bufferAdjustL l buf@Buffer{ bufR=w } + | l == w = buf{ bufL=0, bufR=0 } + | otherwise = buf{ bufL=l, bufR=w } + +bufferAdd :: Int -> Buffer e -> Buffer e +bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i } + +emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e +emptyBuffer raw sz state = + Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz } + +newByteBuffer :: Int -> BufferState -> IO (Buffer Word8) +newByteBuffer c st = newBuffer c c st + +newCharBuffer :: Int -> BufferState -> IO CharBuffer +newCharBuffer c st = newBuffer (c * charSize) c st + +newBuffer :: Int -> Int -> BufferState -> IO (Buffer e) +newBuffer bytes sz state = do + fp <- mallocForeignPtrBytes bytes + return (emptyBuffer fp sz state) + +-- | slides the contents of the buffer to the beginning +slideContents :: Buffer Word8 -> IO (Buffer Word8) +slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do + let elems = r - l + withRawBuffer raw $ \p -> + do _ <- memcpy p (p `plusPtr` l) (fromIntegral elems) + return () + return buf{ bufL=0, bufR=elems } + +foreign import ccall unsafe "memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ()) + +summaryBuffer :: Buffer a -> String +summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" + +-- INVARIANTS on Buffers: +-- * r <= w +-- * if r == w, and the buffer is for reading, then r == 0 && w == 0 +-- * a write buffer is never full. If an operation +-- fills up the buffer, it will always flush it before +-- returning. +-- * a read buffer may be full as a result of hLookAhead. In normal +-- operation, a read buffer always has at least one character of space. + +checkBuffer :: Buffer a -> IO () +checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do + check buf ( + size > 0 + && r <= w + && w <= size + && ( r /= w || state == WriteBuffer || (r == 0 && w == 0) ) + && ( state /= WriteBuffer || w < size ) -- write buffer is never full + ) + +check :: Buffer a -> Bool -> IO () +check _ True = return () +check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf) diff --git a/lib/base/src/GHC/IO/BufferedIO.hs b/lib/base/src/GHC/IO/BufferedIO.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/BufferedIO.hs @@ -0,0 +1,127 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.BufferedIO +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Class of buffered IO devices +-- +----------------------------------------------------------------------------- + +module GHC.IO.BufferedIO ( + BufferedIO(..), + readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking + ) where + +import GHC.Base +import GHC.Ptr +import Data.Word +import GHC.Num +import GHC.Real +import Data.Maybe +-- import GHC.IO +import GHC.IO.Device as IODevice +import GHC.IO.Device as RawIO +import GHC.IO.Buffer + +-- | The purpose of 'BufferedIO' is to provide a common interface for I/O +-- devices that can read and write data through a buffer. Devices that +-- implement 'BufferedIO' include ordinary files, memory-mapped files, +-- and bytestrings. The underlying device implementing a 'Handle' must +-- provide 'BufferedIO'. +-- +class BufferedIO dev where + -- | allocate a new buffer. The size of the buffer is at the + -- discretion of the device; e.g. for a memory-mapped file the + -- buffer will probably cover the entire file. + newBuffer :: dev -> BufferState -> IO (Buffer Word8) + + -- | reads bytes into the buffer, blocking if there are no bytes + -- available. Returns the number of bytes read (zero indicates + -- end-of-file), and the new buffer. + fillReadBuffer :: dev -> Buffer Word8 -> IO (Int, Buffer Word8) + + -- | reads bytes into the buffer without blocking. Returns the + -- number of bytes read (Nothing indicates end-of-file), and the new + -- buffer. + fillReadBuffer0 :: dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8) + + -- | Prepares an empty write buffer. This lets the device decide + -- how to set up a write buffer: the buffer may need to point to a + -- specific location in memory, for example. This is typically used + -- by the client when switching from reading to writing on a + -- buffered read/write device. + -- + -- There is no corresponding operation for read buffers, because before + -- reading the client will always call 'fillReadBuffer'. + emptyWriteBuffer :: dev -> Buffer Word8 -> IO (Buffer Word8) + emptyWriteBuffer _dev buf + = return buf{ bufL=0, bufR=0, bufState = WriteBuffer } + + -- | Flush all the data from the supplied write buffer out to the device. + -- The returned buffer should be empty, and ready for writing. + flushWriteBuffer :: dev -> Buffer Word8 -> IO (Buffer Word8) + + -- | Flush data from the supplied write buffer out to the device + -- without blocking. Returns the number of bytes written and the + -- remaining buffer. + flushWriteBuffer0 :: dev -> Buffer Word8 -> IO (Int, Buffer Word8) + +-- for an I/O device, these operations will perform reading/writing +-- to/from the device. + +-- for a memory-mapped file, the buffer will be the whole file in +-- memory. fillReadBuffer sets the pointers to encompass the whole +-- file, and flushWriteBuffer needs to do no I/O. A memory-mapped +-- file has to maintain its own file pointer. + +-- for a bytestring, again the buffer should match the bytestring in +-- memory. + +-- --------------------------------------------------------------------------- +-- Low-level read/write to/from buffers + +-- These operations make it easy to implement an instance of 'BufferedIO' +-- for an object that supports 'RawIO'. + +readBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8) +readBuf dev bbuf = do + let bytes = bufferAvailable bbuf + res <- withBuffer bbuf $ \ptr -> + RawIO.read dev (ptr `plusPtr` bufR bbuf) (fromIntegral bytes) + let res' = fromIntegral res + return (res', bbuf{ bufR = bufR bbuf + res' }) + -- zero indicates end of file + +readBufNonBlocking :: RawIO dev => dev -> Buffer Word8 + -> IO (Maybe Int, -- Nothing ==> end of file + -- Just n ==> n bytes were read (n>=0) + Buffer Word8) +readBufNonBlocking dev bbuf = do + let bytes = bufferAvailable bbuf + res <- withBuffer bbuf $ \ptr -> + IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) (fromIntegral bytes) + case res of + Nothing -> return (Nothing, bbuf) + Just n -> return (Just n, bbuf{ bufR = bufR bbuf + fromIntegral n }) + +writeBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Buffer Word8) +writeBuf dev bbuf = do + let bytes = bufferElems bbuf + withBuffer bbuf $ \ptr -> + IODevice.write dev (ptr `plusPtr` bufL bbuf) (fromIntegral bytes) + return bbuf{ bufL=0, bufR=0 } + +-- XXX ToDo +writeBufNonBlocking :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8) +writeBufNonBlocking dev bbuf = do + let bytes = bufferElems bbuf + res <- withBuffer bbuf $ \ptr -> + IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) + (fromIntegral bytes) + return (res, bufferAdjustL res bbuf) diff --git a/lib/base/src/GHC/IO/Device.hs b/lib/base/src/GHC/IO/Device.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Device.hs @@ -0,0 +1,152 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Device +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Type classes for I/O providers. +-- +----------------------------------------------------------------------------- + +module GHC.IO.Device ( + RawIO(..), + IODevice(..), + IODeviceType(..), + SeekMode(..) + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Word +import GHC.Arr +import GHC.Enum +import GHC.Read +import GHC.Show +import GHC.Ptr +import Data.Maybe +import GHC.Num +import GHC.IO +import {-# SOURCE #-} GHC.IO.Exception ( unsupportedOperation ) +#endif +#ifdef __NHC__ +import Foreign +import Ix +import Control.Exception.Base +unsupportedOperation = userError "unsupported operation" +#endif + +-- | A low-level I/O provider where the data is bytes in memory. +class RawIO a where + -- | Read up to the specified number of bytes, returning the number + -- of bytes actually read. This function should only block if there + -- is no data available. If there is not enough data available, + -- then the function should just return the available data. A return + -- value of zero indicates that the end of the data stream (e.g. end + -- of file) has been reached. + read :: a -> Ptr Word8 -> Int -> IO Int + + -- | Read up to the specified number of bytes, returning the number + -- of bytes actually read, or 'Nothing' if the end of the stream has + -- been reached. + readNonBlocking :: a -> Ptr Word8 -> Int -> IO (Maybe Int) + + -- | Write the specified number of bytes. + write :: a -> Ptr Word8 -> Int -> IO () + + -- | Write up to the specified number of bytes without blocking. Returns + -- the actual number of bytes written. + writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int + + +-- | I/O operations required for implementing a 'Handle'. +class IODevice a where + -- | @ready dev write msecs@ returns 'True' if the device has data + -- to read (if @write@ is 'False') or space to write new data (if + -- @write@ is 'True'). @msecs@ specifies how long to wait, in + -- milliseconds. + -- + ready :: a -> Bool -> Int -> IO Bool + + -- | closes the device. Further operations on the device should + -- produce exceptions. + close :: a -> IO () + + -- | returns 'True' if the device is a terminal or console. + isTerminal :: a -> IO Bool + isTerminal _ = return False + + -- | returns 'True' if the device supports 'seek' operations. + isSeekable :: a -> IO Bool + isSeekable _ = return False + + -- | seek to the specified position in the data. + seek :: a -> SeekMode -> Integer -> IO () + seek _ _ _ = ioe_unsupportedOperation + + -- | return the current position in the data. + tell :: a -> IO Integer + tell _ = ioe_unsupportedOperation + + -- | return the size of the data. + getSize :: a -> IO Integer + getSize _ = ioe_unsupportedOperation + + -- | change the size of the data. + setSize :: a -> Integer -> IO () + setSize _ _ = ioe_unsupportedOperation + + -- | for terminal devices, changes whether characters are echoed on + -- the device. + setEcho :: a -> Bool -> IO () + setEcho _ _ = ioe_unsupportedOperation + + -- | returns the current echoing status. + getEcho :: a -> IO Bool + getEcho _ = ioe_unsupportedOperation + + -- | some devices (e.g. terminals) support a "raw" mode where + -- characters entered are immediately made available to the program. + -- If available, this operations enables raw mode. + setRaw :: a -> Bool -> IO () + setRaw _ _ = ioe_unsupportedOperation + + -- | returns the 'IODeviceType' corresponding to this device. + devType :: a -> IO IODeviceType + + -- | duplicates the device, if possible. The new device is expected + -- to share a file pointer with the original device (like Unix @dup@). + dup :: a -> IO a + dup _ = ioe_unsupportedOperation + + -- | @dup2 source target@ replaces the target device with the source + -- device. The target device is closed first, if necessary, and then + -- it is made into a duplicate of the first device (like Unix @dup2@). + dup2 :: a -> a -> IO a + dup2 _ _ = ioe_unsupportedOperation + +ioe_unsupportedOperation :: IO a +ioe_unsupportedOperation = throwIO unsupportedOperation + +data IODeviceType + = Directory + | Stream + | RegularFile + | RawDevice + deriving (Eq) + +-- ----------------------------------------------------------------------------- +-- SeekMode type + +-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows: +data SeekMode + = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. + | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ + -- from the current position. + | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ + -- from the end of the file. + deriving (Eq, Ord, Ix, Enum, Read, Show) diff --git a/lib/base/src/GHC/IO/Encoding.hs b/lib/base/src/GHC/IO/Encoding.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding.hs @@ -0,0 +1,155 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Text codecs for I/O +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding ( + BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder, + latin1, latin1_encode, latin1_decode, + utf8, utf8_bom, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding, + mkTextEncoding, + ) where + +import GHC.Base +--import GHC.IO +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +#if !defined(mingw32_HOST_OS) +import qualified GHC.IO.Encoding.Iconv as Iconv +#else +import qualified GHC.IO.Encoding.CodePage as CodePage +import Text.Read (reads) +#endif +import qualified GHC.IO.Encoding.Latin1 as Latin1 +import qualified GHC.IO.Encoding.UTF8 as UTF8 +import qualified GHC.IO.Encoding.UTF16 as UTF16 +import qualified GHC.IO.Encoding.UTF32 as UTF32 + +#if defined(mingw32_HOST_OS) +import Data.Maybe +import GHC.IO.Exception +#endif + +-- ----------------------------------------------------------------------------- + +-- | The Latin1 (ISO8859-1) encoding. This encoding maps bytes +-- directly to the first 256 Unicode code points, and is thus not a +-- complete Unicode encoding. An attempt to write a character greater than +-- '\255' to a 'Handle' using the 'latin1' encoding will result in an error. +latin1 :: TextEncoding +latin1 = Latin1.latin1_checked + +-- | The UTF-8 Unicode encoding +utf8 :: TextEncoding +utf8 = UTF8.utf8 + +-- | The UTF-8 Unicode encoding, with a byte-order-mark (BOM; the byte +-- sequence 0xEF 0xBB 0xBF). This encoding behaves like 'utf8', +-- except that on input, the BOM sequence is ignored at the beginning +-- of the stream, and on output, the BOM sequence is prepended. +-- +-- The byte-order-mark is strictly unnecessary in UTF-8, but is +-- sometimes used to identify the encoding of a file. +-- +utf8_bom :: TextEncoding +utf8_bom = UTF8.utf8_bom + +-- | The UTF-16 Unicode encoding (a byte-order-mark should be used to +-- indicate endianness). +utf16 :: TextEncoding +utf16 = UTF16.utf16 + +-- | The UTF-16 Unicode encoding (litte-endian) +utf16le :: TextEncoding +utf16le = UTF16.utf16le + +-- | The UTF-16 Unicode encoding (big-endian) +utf16be :: TextEncoding +utf16be = UTF16.utf16be + +-- | The UTF-32 Unicode encoding (a byte-order-mark should be used to +-- indicate endianness). +utf32 :: TextEncoding +utf32 = UTF32.utf32 + +-- | The UTF-32 Unicode encoding (litte-endian) +utf32le :: TextEncoding +utf32le = UTF32.utf32le + +-- | The UTF-32 Unicode encoding (big-endian) +utf32be :: TextEncoding +utf32be = UTF32.utf32be + +-- | The Unicode encoding of the current locale +localeEncoding :: TextEncoding +#if !defined(mingw32_HOST_OS) +localeEncoding = Iconv.localeEncoding +#else +localeEncoding = CodePage.localeEncoding +#endif + +-- | Look up the named Unicode encoding. May fail with +-- +-- * 'isDoesNotExistError' if the encoding is unknown +-- +-- The set of known encodings is system-dependent, but includes at least: +-- +-- * @UTF-8@ +-- +-- * @UTF-16@, @UTF-16BE@, @UTF-16LE@ +-- +-- * @UTF-32@, @UTF-32BE@, @UTF-32LE@ +-- +-- On systems using GNU iconv (e.g. Linux), there is additional +-- notation for specifying how illegal characters are handled: +-- +-- * a suffix of @\/\/IGNORE@, e.g. @UTF-8\/\/IGNORE@, will cause +-- all illegal sequences on input to be ignored, and on output +-- will drop all code points that have no representation in the +-- target encoding. +-- +-- * a suffix of @\/\/TRANSLIT@ will choose a replacement character +-- for illegal sequences or code points. +-- +-- On Windows, you can access supported code pages with the prefix +-- @CP@; for example, @\"CP1250\"@. +-- +mkTextEncoding :: String -> IO TextEncoding +#if !defined(mingw32_HOST_OS) +mkTextEncoding = Iconv.mkTextEncoding +#else +mkTextEncoding "UTF-8" = return utf8 +mkTextEncoding "UTF-16" = return utf16 +mkTextEncoding "UTF-16LE" = return utf16le +mkTextEncoding "UTF-16BE" = return utf16be +mkTextEncoding "UTF-32" = return utf32 +mkTextEncoding "UTF-32LE" = return utf32le +mkTextEncoding "UTF-32BE" = return utf32be +mkTextEncoding ('C':'P':n) + | [(cp,"")] <- reads n = return $ CodePage.codePageEncoding cp +mkTextEncoding e = ioException + (IOError Nothing NoSuchThing "mkTextEncoding" + ("unknown encoding:" ++ e) Nothing Nothing) +#endif + +latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8) +latin1_encode = Latin1.latin1_encode -- unchecked, used for binary +--latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode + +latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer) +latin1_decode = Latin1.latin1_decode +--latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode diff --git a/lib/base/src/GHC/IO/Encoding/CodePage.hs b/lib/base/src/GHC/IO/Encoding/CodePage.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/CodePage.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE BangPatterns #-} +module GHC.IO.Encoding.CodePage( +#if !defined(mingw32_HOST_OS) + ) where +#else + codePageEncoding, + localeEncoding + ) where + +import GHC.Base +import GHC.Num +import GHC.Enum +import GHC.Word +import GHC.IO (unsafePerformIO) +import GHC.IO.Encoding.Types +import GHC.IO.Buffer +import GHC.IO.Exception +import Data.Bits +import Data.Maybe +import Data.List (lookup) + +import GHC.IO.Encoding.CodePage.Table + +import GHC.IO.Encoding.Latin1 (latin1) +import GHC.IO.Encoding.UTF8 (utf8) +import GHC.IO.Encoding.UTF16 (utf16le, utf16be) +import GHC.IO.Encoding.UTF32 (utf32le, utf32be) + +-- note CodePage = UInt which might not work on Win64. But the Win32 package +-- also has this issue. +getCurrentCodePage :: IO Word32 +getCurrentCodePage = do + conCP <- getConsoleCP + if conCP > 0 + then return conCP + else getACP + +-- Since the Win32 package depends on base, we have to import these ourselves: +foreign import stdcall unsafe "windows.h GetConsoleCP" + getConsoleCP :: IO Word32 + +foreign import stdcall unsafe "windows.h GetACP" + getACP :: IO Word32 + +{-# NOINLINE localeEncoding #-} +localeEncoding :: TextEncoding +localeEncoding = unsafePerformIO $ fmap codePageEncoding getCurrentCodePage + + +codePageEncoding :: Word32 -> TextEncoding +codePageEncoding 65001 = utf8 +codePageEncoding 1200 = utf16le +codePageEncoding 1201 = utf16be +codePageEncoding 12000 = utf32le +codePageEncoding 12001 = utf32be +codePageEncoding cp = maybe latin1 buildEncoding (lookup cp codePageMap) + +buildEncoding :: CodePageArrays -> TextEncoding +buildEncoding SingleByteCP {decoderArray = dec, encoderArray = enc} + = TextEncoding { + mkTextDecoder = return $ simpleCodec + $ decodeFromSingleByte dec + , mkTextEncoder = return $ simpleCodec $ encodeToSingleByte enc + } + +simpleCodec :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to)) + -> BufferCodec from to () +simpleCodec f = BufferCodec {encode = f, close = return (), getState = return (), + setState = return } + +decodeFromSingleByte :: ConvArray Char -> DecodeBuffer +decodeFromSingleByte convArr + input@Buffer { bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer { bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir==iw then input{ bufL=0, bufR=0} + else input{ bufL=ir}, + output {bufR=ow}) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + b <- readWord8Buf iraw ir + let c = lookupConv convArr b + if c=='\0' && b /= 0 then invalid else do + ow' <- writeCharBuf oraw ow c + loop (ir+1) ow' + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + in loop ir0 ow0 + +encodeToSingleByte :: CompactArray Char Word8 -> EncodeBuffer +encodeToSingleByte CompactArray { encoderMax = maxChar, + encoderIndices = indices, + encoderValues = values } + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir==iw then input { bufL=0, bufR=0 } + else input { bufL=ir }, + output {bufR=ow}) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case lookupCompact maxChar indices values c of + Nothing -> invalid + Just 0 | c /= '\0' -> invalid + Just b -> do + writeWord8Buf oraw ow b + loop ir' (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_encodingError + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "codePageEncoding" + "invalid code page byte sequence" Nothing Nothing) + +ioe_encodingError :: IO a +ioe_encodingError = ioException + (IOError Nothing InvalidArgument "codePageEncoding" + "character is not in the code page" Nothing Nothing) + + +-------------------------------------------- +-- Array access functions + +-- {-# INLINE lookupConv #-} +lookupConv :: ConvArray Char -> Word8 -> Char +lookupConv a = indexChar a . fromEnum + +{-# INLINE lookupCompact #-} +lookupCompact :: Char -> ConvArray Int -> ConvArray Word8 -> Char -> Maybe Word8 +lookupCompact maxVal indexes values x + | x > maxVal = Nothing + | otherwise = Just $ indexWord8 values $ j + (i .&. mask) + where + i = fromEnum x + mask = (1 `shiftL` n) - 1 + k = i `shiftR` n + j = indexInt indexes k + n = blockBitSize + +{-# INLINE indexInt #-} +indexInt :: ConvArray Int -> Int -> Int +indexInt (ConvArray p) (I# i) = I# (indexInt16OffAddr# p i) + +{-# INLINE indexWord8 #-} +indexWord8 :: ConvArray Word8 -> Int -> Word8 +indexWord8 (ConvArray p) (I# i) = W8# (indexWord8OffAddr# p i) + +{-# INLINE indexChar #-} +indexChar :: ConvArray Char -> Int -> Char +indexChar (ConvArray p) (I# i) = C# (chr# (indexInt16OffAddr# p i)) + +#endif diff --git a/lib/base/src/GHC/IO/Encoding/CodePage/Table.hs b/lib/base/src/GHC/IO/Encoding/CodePage/Table.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/CodePage/Table.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE MagicHash #-} +-- Do not edit this file directly! +-- It was generated by the MakeTable.hs script using the following files: +-- CP037.TXT +-- CP1026.TXT +-- CP1250.TXT +-- CP1251.TXT +-- CP1252.TXT +-- CP1253.TXT +-- CP1254.TXT +-- CP1255.TXT +-- CP1256.TXT +-- CP1257.TXT +-- CP1258.TXT +-- CP437.TXT +-- CP500.TXT +-- CP737.TXT +-- CP775.TXT +-- CP850.TXT +-- CP852.TXT +-- CP855.TXT +-- CP857.TXT +-- CP860.TXT +-- CP861.TXT +-- CP862.TXT +-- CP863.TXT +-- CP864.TXT +-- CP865.TXT +-- CP866.TXT +-- CP869.TXT +-- CP874.TXT +-- CP875.TXT +module GHC.IO.Encoding.CodePage.Table where + +import GHC.Prim +import GHC.Base +import GHC.Word +import GHC.Num +data ConvArray a = ConvArray Addr# +data CompactArray a b = CompactArray { + encoderMax :: !a, + encoderIndices :: !(ConvArray Int), + encoderValues :: !(ConvArray b) + } + +data CodePageArrays = SingleByteCP { + decoderArray :: !(ConvArray Char), + encoderArray :: !(CompactArray Char Word8) + } + +blockBitSize :: Int +blockBitSize = 6 +codePageMap :: [(Word32, CodePageArrays)] +codePageMap = [ + (37, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\xa0\x0\xe2\x0\xe4\x0\xe0\x0\xe1\x0\xe3\x0\xe5\x0\xe7\x0\xf1\x0\xa2\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x7c\x0\x26\x0\xe9\x0\xea\x0\xeb\x0\xe8\x0\xed\x0\xee\x0\xef\x0\xec\x0\xdf\x0\x21\x0\x24\x0\x2a\x0\x29\x0\x3b\x0\xac\x0\x2d\x0\x2f\x0\xc2\x0\xc4\x0\xc0\x0\xc1\x0\xc3\x0\xc5\x0\xc7\x0\xd1\x0\xa6\x0\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xf8\x0\xc9\x0\xca\x0\xcb\x0\xc8\x0\xcd\x0\xce\x0\xcf\x0\xcc\x0\x60\x0\x3a\x0\x23\x0\x40\x0\x27\x0\x3d\x0\x22\x0\xd8\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xab\x0\xbb\x0\xf0\x0\xfd\x0\xfe\x0\xb1\x0\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xaa\x0\xba\x0\xe6\x0\xb8\x0\xc6\x0\xa4\x0\xb5\x0\x7e\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xa1\x0\xbf\x0\xd0\x0\xdd\x0\xde\x0\xae\x0\x5e\x0\xa3\x0\xa5\x0\xb7\x0\xa9\x0\xa7\x0\xb6\x0\xbc\x0\xbd\x0\xbe\x0\x5b\x0\x5d\x0\xaf\x0\xa8\x0\xb4\x0\xd7\x0\x7b\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xf4\x0\xf6\x0\xf2\x0\xf3\x0\xf5\x0\x7d\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb9\x0\xfb\x0\xfc\x0\xf9\x0\xfa\x0\xff\x0\x5c\x0\xf7\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xd4\x0\xd6\x0\xd2\x0\xd3\x0\xd5\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xdb\x0\xdc\x0\xd9\x0\xda\x0\x9f\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f\x40\x5a\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xba\xe0\xbb\xb0\x6d\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\x4f\xd0\xa1\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x41\xaa\x4a\xb1\x9f\xb2\x6a\xb5\xbd\xb4\x9a\x8a\x5f\xca\xaf\xbc\x90\x8f\xea\xfa\xbe\xa0\xb6\xb3\x9d\xda\x9b\x8b\xb7\xb8\xb9\xab\x64\x65\x62\x66\x63\x67\x9e\x68\x74\x71\x72\x73\x78\x75\x76\x77\xac\x69\xed\xee\xeb\xef\xec\xbf\x80\xfd\xfe\xfb\xfc\xad\xae\x59\x44\x45\x42\x46\x43\x47\x9c\x48\x54\x51\x52\x53\x58\x55\x56\x57\x8c\x49\xcd\xce\xcb\xcf\xcc\xe1\x70\xdd\xde\xdb\xdc\x8d\x8e\xdf"# + , encoderMax = '\255' + } + + } + ) + + , + (1026, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\xa0\x0\xe2\x0\xe4\x0\xe0\x0\xe1\x0\xe3\x0\xe5\x0\x7b\x0\xf1\x0\xc7\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x21\x0\x26\x0\xe9\x0\xea\x0\xeb\x0\xe8\x0\xed\x0\xee\x0\xef\x0\xec\x0\xdf\x0\x1e\x1\x30\x1\x2a\x0\x29\x0\x3b\x0\x5e\x0\x2d\x0\x2f\x0\xc2\x0\xc4\x0\xc0\x0\xc1\x0\xc3\x0\xc5\x0\x5b\x0\xd1\x0\x5f\x1\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xf8\x0\xc9\x0\xca\x0\xcb\x0\xc8\x0\xcd\x0\xce\x0\xcf\x0\xcc\x0\x31\x1\x3a\x0\xd6\x0\x5e\x1\x27\x0\x3d\x0\xdc\x0\xd8\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xab\x0\xbb\x0\x7d\x0\x60\x0\xa6\x0\xb1\x0\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xaa\x0\xba\x0\xe6\x0\xb8\x0\xc6\x0\xa4\x0\xb5\x0\xf6\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xa1\x0\xbf\x0\x5d\x0\x24\x0\x40\x0\xae\x0\xa2\x0\xa3\x0\xa5\x0\xb7\x0\xa9\x0\xa7\x0\xb6\x0\xbc\x0\xbd\x0\xbe\x0\xac\x0\x7c\x0\xaf\x0\xa8\x0\xb4\x0\xd7\x0\xe7\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xf4\x0\x7e\x0\xf2\x0\xf3\x0\xf5\x0\x1f\x1\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb9\x0\xfb\x0\x5c\x0\xf9\x0\xfa\x0\xff\x0\xfc\x0\xf7\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xd4\x0\x23\x0\xd2\x0\xd3\x0\xd5\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xdb\x0\x22\x0\xd9\x0\xda\x0\x9f\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f\x40\x4f\xfc\xec\xad\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\xae\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\x68\xdc\xac\x5f\x6d\x8d\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\x48\xbb\x8c\xcc\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x41\xaa\xb0\xb1\x9f\xb2\x8e\xb5\xbd\xb4\x9a\x8a\xba\xca\xaf\xbc\x90\x8f\xea\xfa\xbe\xa0\xb6\xb3\x9d\xda\x9b\x8b\xb7\xb8\xb9\xab\x64\x65\x62\x66\x63\x67\x9e\x4a\x74\x71\x72\x73\x78\x75\x76\x77\x0\x69\xed\xee\xeb\xef\x7b\xbf\x80\xfd\xfe\xfb\x7f\x0\x0\x59\x44\x45\x42\x46\x43\x47\x9c\xc0\x54\x51\x52\x53\x58\x55\x56\x57\x0\x49\xcd\xce\xcb\xcf\xa1\xe1\x70\xdd\xde\xdb\xe0\x0\x0\xdf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x5a\xd0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x5b\x79\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x7c\x6a"# + , encoderMax = '\351' + } + + } + ) + + , + (1250, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x0\x0\x1e\x20\x26\x20\x20\x20\x21\x20\x0\x0\x30\x20\x60\x1\x39\x20\x5a\x1\x64\x1\x7d\x1\x79\x1\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x61\x1\x3a\x20\x5b\x1\x65\x1\x7e\x1\x7a\x1\xa0\x0\xc7\x2\xd8\x2\x41\x1\xa4\x0\x4\x1\xa6\x0\xa7\x0\xa8\x0\xa9\x0\x5e\x1\xab\x0\xac\x0\xad\x0\xae\x0\x7b\x1\xb0\x0\xb1\x0\xdb\x2\x42\x1\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\x5\x1\x5f\x1\xbb\x0\x3d\x1\xdd\x2\x3e\x1\x7c\x1\x54\x1\xc1\x0\xc2\x0\x2\x1\xc4\x0\x39\x1\x6\x1\xc7\x0\xc\x1\xc9\x0\x18\x1\xcb\x0\x1a\x1\xcd\x0\xce\x0\xe\x1\x10\x1\x43\x1\x47\x1\xd3\x0\xd4\x0\x50\x1\xd6\x0\xd7\x0\x58\x1\x6e\x1\xda\x0\x70\x1\xdc\x0\xdd\x0\x62\x1\xdf\x0\x55\x1\xe1\x0\xe2\x0\x3\x1\xe4\x0\x3a\x1\x7\x1\xe7\x0\xd\x1\xe9\x0\x19\x1\xeb\x0\x1b\x1\xed\x0\xee\x0\xf\x1\x11\x1\x44\x1\x48\x1\xf3\x0\xf4\x0\x51\x1\xf6\x0\xf7\x0\x59\x1\x6f\x1\xfa\x0\x71\x1\xfc\x0\xfd\x0\x63\x1\xd9\x2"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x80\x1\x40\x2\x80\x1\x80\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\x0\xa4\x0\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\x0\xb0\xb1\x0\x0\xb4\xb5\xb6\xb7\xb8\x0\x0\xbb\x0\x0\x0\x0\x0\xc1\xc2\x0\xc4\x0\x0\xc7\x0\xc9\x0\xcb\x0\xcd\xce\x0\x0\x0\x0\xd3\xd4\x0\xd6\xd7\x0\x0\xda\x0\xdc\xdd\x0\xdf\x0\xe1\xe2\x0\xe4\x0\x0\xe7\x0\xe9\x0\xeb\x0\xed\xee\x0\x0\x0\x0\xf3\xf4\x0\xf6\xf7\x0\x0\xfa\x0\xfc\xfd\x0\x0\x0\x0\xc3\xe3\xa5\xb9\xc6\xe6\x0\x0\x0\x0\xc8\xe8\xcf\xef\xd0\xf0\x0\x0\x0\x0\x0\x0\xca\xea\xcc\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc5\xe5\x0\x0\xbc\xbe\x0\x0\xa3\xb3\xd1\xf1\x0\x0\xd2\xf2\x0\x0\x0\x0\x0\x0\x0\xd5\xf5\x0\x0\xc0\xe0\x0\x0\xd8\xf8\x8c\x9c\x0\x0\xaa\xba\x8a\x9a\xde\xfe\x8d\x9d\x0\x0\x0\x0\x0\x0\x0\x0\xd9\xf9\xdb\xfb\x0\x0\x0\x0\x0\x0\x0\x8f\x9f\xaf\xbf\x8e\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa2\xff\x0\xb2\x0\xbd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1251, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x2\x4\x3\x4\x1a\x20\x53\x4\x1e\x20\x26\x20\x20\x20\x21\x20\xac\x20\x30\x20\x9\x4\x39\x20\xa\x4\xc\x4\xb\x4\xf\x4\x52\x4\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x59\x4\x3a\x20\x5a\x4\x5c\x4\x5b\x4\x5f\x4\xa0\x0\xe\x4\x5e\x4\x8\x4\xa4\x0\x90\x4\xa6\x0\xa7\x0\x1\x4\xa9\x0\x4\x4\xab\x0\xac\x0\xad\x0\xae\x0\x7\x4\xb0\x0\xb1\x0\x6\x4\x56\x4\x91\x4\xb5\x0\xb6\x0\xb7\x0\x51\x4\x16\x21\x54\x4\xbb\x0\x58\x4\x5\x4\x55\x4\x57\x4\x10\x4\x11\x4\x12\x4\x13\x4\x14\x4\x15\x4\x16\x4\x17\x4\x18\x4\x19\x4\x1a\x4\x1b\x4\x1c\x4\x1d\x4\x1e\x4\x1f\x4\x20\x4\x21\x4\x22\x4\x23\x4\x24\x4\x25\x4\x26\x4\x27\x4\x28\x4\x29\x4\x2a\x4\x2b\x4\x2c\x4\x2d\x4\x2e\x4\x2f\x4\x30\x4\x31\x4\x32\x4\x33\x4\x34\x4\x35\x4\x36\x4\x37\x4\x38\x4\x39\x4\x3a\x4\x3b\x4\x3c\x4\x3d\x4\x3e\x4\x3f\x4\x40\x4\x41\x4\x42\x4\x43\x4\x44\x4\x45\x4\x46\x4\x47\x4\x48\x4\x49\x4\x4a\x4\x4b\x4\x4c\x4\x4d\x4\x4e\x4\x4f\x4"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\xc0\x0\x0\x2\xc0\x0\x40\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\x0\xa4\x0\xa6\xa7\x0\xa9\x0\xab\xac\xad\xae\x0\xb0\xb1\x0\x0\x0\xb5\xb6\xb7\x0\x0\x0\xbb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa8\x80\x81\xaa\xbd\xb2\xaf\xa3\x8a\x8c\x8e\x8d\x0\xa1\x8f\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x0\xb8\x90\x83\xba\xbe\xb3\xbf\xbc\x9a\x9c\x9e\x9d\x0\xa2\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa5\xb4\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xb9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1252, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x60\x1\x39\x20\x52\x1\x0\x0\x7d\x1\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x61\x1\x3a\x20\x53\x1\x0\x0\x7e\x1\x78\x1\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xaa\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xba\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xc0\x0\xc1\x0\xc2\x0\xc3\x0\xc4\x0\xc5\x0\xc6\x0\xc7\x0\xc8\x0\xc9\x0\xca\x0\xcb\x0\xcc\x0\xcd\x0\xce\x0\xcf\x0\xd0\x0\xd1\x0\xd2\x0\xd3\x0\xd4\x0\xd5\x0\xd6\x0\xd7\x0\xd8\x0\xd9\x0\xda\x0\xdb\x0\xdc\x0\xdd\x0\xde\x0\xdf\x0\xe0\x0\xe1\x0\xe2\x0\xe3\x0\xe4\x0\xe5\x0\xe6\x0\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\xec\x0\xed\x0\xee\x0\xef\x0\xf0\x0\xf1\x0\xf2\x0\xf3\x0\xf4\x0\xf5\x0\xf6\x0\xf7\x0\xf8\x0\xf9\x0\xfa\x0\xfb\x0\xfc\x0\xfd\x0\xfe\x0\xff\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x0\x1\x40\x2\x0\x1\x80\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8a\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x8e\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1253, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\x0\x0\x30\x20\x0\x0\x39\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x0\x0\x3a\x20\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x85\x3\x86\x3\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\x0\x0\xab\x0\xac\x0\xad\x0\xae\x0\x15\x20\xb0\x0\xb1\x0\xb2\x0\xb3\x0\x84\x3\xb5\x0\xb6\x0\xb7\x0\x88\x3\x89\x3\x8a\x3\xbb\x0\x8c\x3\xbd\x0\x8e\x3\x8f\x3\x90\x3\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\x98\x3\x99\x3\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x9e\x3\x9f\x3\xa0\x3\xa1\x3\x0\x0\xa3\x3\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xaa\x3\xab\x3\xac\x3\xad\x3\xae\x3\xaf\x3\xb0\x3\xb1\x3\xb2\x3\xb3\x3\xb4\x3\xb5\x3\xb6\x3\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc2\x3\xc3\x3\xc4\x3\xc5\x3\xc6\x3\xc7\x3\xc8\x3\xc9\x3\xca\x3\xcb\x3\xcc\x3\xcd\x3\xce\x3\x0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x40\x1\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\xc0\x0\x0\x2\xc0\x0\x40\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\xa3\xa4\xa5\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\x0\xb0\xb1\xb2\xb3\x0\xb5\xb6\xb7\x0\x0\x0\xbb\x0\xbd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xb4\xa1\xa2\x0\xb8\xb9\xba\x0\xbc\x0\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\x0\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\xaf\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1254, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x60\x1\x39\x20\x52\x1\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x61\x1\x3a\x20\x53\x1\x0\x0\x0\x0\x78\x1\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xaa\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xba\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xc0\x0\xc1\x0\xc2\x0\xc3\x0\xc4\x0\xc5\x0\xc6\x0\xc7\x0\xc8\x0\xc9\x0\xca\x0\xcb\x0\xcc\x0\xcd\x0\xce\x0\xcf\x0\x1e\x1\xd1\x0\xd2\x0\xd3\x0\xd4\x0\xd5\x0\xd6\x0\xd7\x0\xd8\x0\xd9\x0\xda\x0\xdb\x0\xdc\x0\x30\x1\x5e\x1\xdf\x0\xe0\x0\xe1\x0\xe2\x0\xe3\x0\xe4\x0\xe5\x0\xe6\x0\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\xec\x0\xed\x0\xee\x0\xef\x0\x1f\x1\xf1\x0\xf2\x0\xf3\x0\xf4\x0\xf5\x0\xf6\x0\xf7\x0\xf8\x0\xf9\x0\xfa\x0\xfb\x0\xfc\x0\x31\x1\x5f\x1\xff\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x0\x2\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x40\x2\xc0\x1\x80\x2\xc0\x1\xc0\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\x0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\x0\x0\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\x0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\x0\x0\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdd\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xde\xfe\x8a\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1255, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x0\x0\x39\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x0\x0\x3a\x20\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xaa\x20\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xd7\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xf7\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xb0\x5\xb1\x5\xb2\x5\xb3\x5\xb4\x5\xb5\x5\xb6\x5\xb7\x5\xb8\x5\xb9\x5\x0\x0\xbb\x5\xbc\x5\xbd\x5\xbe\x5\xbf\x5\xc0\x5\xc1\x5\xc2\x5\xc3\x5\xf0\x5\xf1\x5\xf2\x5\xf3\x5\xf4\x5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd0\x5\xd1\x5\xd2\x5\xd3\x5\xd4\x5\xd5\x5\xd6\x5\xd7\x5\xd8\x5\xd9\x5\xda\x5\xdb\x5\xdc\x5\xdd\x5\xde\x5\xdf\x5\xe0\x5\xe1\x5\xe2\x5\xe3\x5\xe4\x5\xe5\x5\xe6\x5\xe7\x5\xe8\x5\xe9\x5\xea\x5\x0\x0\x0\x0\xe\x20\xf\x20\x0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x0\x1\x80\x2\x0\x1\xc0\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\x0\xa5\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\x0\xbb\xbc\xbd\xbe\xbf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xaa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xba\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\x0\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\x0\x0\x0\x0\x0\xd4\xd5\xd6\xd7\xd8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfd\xfe\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa4\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1256, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x7e\x6\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x79\x6\x39\x20\x52\x1\x86\x6\x98\x6\x88\x6\xaf\x6\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xa9\x6\x22\x21\x91\x6\x3a\x20\x53\x1\xc\x20\xd\x20\xba\x6\xa0\x0\xc\x6\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xbe\x6\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\x1b\x6\xbb\x0\xbc\x0\xbd\x0\xbe\x0\x1f\x6\xc1\x6\x21\x6\x22\x6\x23\x6\x24\x6\x25\x6\x26\x6\x27\x6\x28\x6\x29\x6\x2a\x6\x2b\x6\x2c\x6\x2d\x6\x2e\x6\x2f\x6\x30\x6\x31\x6\x32\x6\x33\x6\x34\x6\x35\x6\x36\x6\xd7\x0\x37\x6\x38\x6\x39\x6\x3a\x6\x40\x6\x41\x6\x42\x6\x43\x6\xe0\x0\x44\x6\xe2\x0\x45\x6\x46\x6\x47\x6\x48\x6\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\x49\x6\x4a\x6\xee\x0\xef\x0\x4b\x6\x4c\x6\x4d\x6\x4e\x6\xf4\x0\x4f\x6\x50\x6\xf7\x0\x51\x6\xf9\x0\x52\x6\xfb\x0\xfc\x0\xe\x20\xf\x20\xd2\x6"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x3\x0\x1\x40\x3\x0\x1\x80\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\x0\xbb\xbc\xbd\xbe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd7\x0\x0\x0\x0\x0\x0\x0\x0\xe0\x0\xe2\x0\x0\x0\x0\xe7\xe8\xe9\xea\xeb\x0\x0\xee\xef\x0\x0\x0\x0\xf4\x0\x0\xf7\x0\xf9\x0\xfb\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xba\x0\x0\x0\xbf\x0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd8\xd9\xda\xdb\x0\x0\x0\x0\x0\xdc\xdd\xde\xdf\xe1\xe3\xe4\xe5\xe6\xec\xed\xf0\xf1\xf2\xf3\xf5\xf6\xf8\xfa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8a\x0\x0\x0\x0\x81\x0\x0\x0\x0\x0\x0\x0\x8d\x0\x8f\x0\x0\x0\x0\x0\x0\x0\x0\x9a\x0\x0\x0\x0\x0\x0\x8e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x90\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\xaa\x0\x0\xc0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9d\x9e\xfd\xfe\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1257, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x0\x0\x1e\x20\x26\x20\x20\x20\x21\x20\x0\x0\x30\x20\x0\x0\x39\x20\x0\x0\xa8\x0\xc7\x2\xb8\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x0\x0\x3a\x20\x0\x0\xaf\x0\xdb\x2\x0\x0\xa0\x0\x0\x0\xa2\x0\xa3\x0\xa4\x0\x0\x0\xa6\x0\xa7\x0\xd8\x0\xa9\x0\x56\x1\xab\x0\xac\x0\xad\x0\xae\x0\xc6\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xf8\x0\xb9\x0\x57\x1\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xe6\x0\x4\x1\x2e\x1\x0\x1\x6\x1\xc4\x0\xc5\x0\x18\x1\x12\x1\xc\x1\xc9\x0\x79\x1\x16\x1\x22\x1\x36\x1\x2a\x1\x3b\x1\x60\x1\x43\x1\x45\x1\xd3\x0\x4c\x1\xd5\x0\xd6\x0\xd7\x0\x72\x1\x41\x1\x5a\x1\x6a\x1\xdc\x0\x7b\x1\x7d\x1\xdf\x0\x5\x1\x2f\x1\x1\x1\x7\x1\xe4\x0\xe5\x0\x19\x1\x13\x1\xd\x1\xe9\x0\x7a\x1\x17\x1\x23\x1\x37\x1\x2b\x1\x3c\x1\x61\x1\x44\x1\x46\x1\xf3\x0\x4d\x1\xf5\x0\xf6\x0\xf7\x0\x73\x1\x42\x1\x5b\x1\x6b\x1\xfc\x0\x7c\x1\x7e\x1\xd9\x2"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x80\x1\x40\x2\x80\x1\x80\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xa2\xa3\xa4\x0\xa6\xa7\x8d\xa9\x0\xab\xac\xad\xae\x9d\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\x8f\xb9\x0\xbb\xbc\xbd\xbe\x0\x0\x0\x0\x0\xc4\xc5\xaf\x0\x0\xc9\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd3\x0\xd5\xd6\xd7\xa8\x0\x0\x0\xdc\x0\x0\xdf\x0\x0\x0\x0\xe4\xe5\xbf\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf3\x0\xf5\xf6\xf7\xb8\x0\x0\x0\xfc\x0\x0\x0\xc2\xe2\x0\x0\xc0\xe0\xc3\xe3\x0\x0\x0\x0\xc8\xe8\x0\x0\x0\x0\xc7\xe7\x0\x0\xcb\xeb\xc6\xe6\x0\x0\x0\x0\x0\x0\x0\x0\xcc\xec\x0\x0\x0\x0\x0\x0\xce\xee\x0\x0\xc1\xe1\x0\x0\x0\x0\x0\x0\xcd\xed\x0\x0\x0\xcf\xef\x0\x0\x0\x0\xd9\xf9\xd1\xf1\xd2\xf2\x0\x0\x0\x0\x0\xd4\xf4\x0\x0\x0\x0\x0\x0\x0\x0\xaa\xba\x0\x0\xda\xfa\x0\x0\x0\x0\xd0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\xdb\xfb\x0\x0\x0\x0\x0\x0\xd8\xf8\x0\x0\x0\x0\x0\xca\xea\xdd\xfd\xde\xfe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (1258, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x0\x0\x39\x20\x52\x1\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x0\x0\x3a\x20\x53\x1\x0\x0\x0\x0\x78\x1\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xaa\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xba\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xc0\x0\xc1\x0\xc2\x0\x2\x1\xc4\x0\xc5\x0\xc6\x0\xc7\x0\xc8\x0\xc9\x0\xca\x0\xcb\x0\x0\x3\xcd\x0\xce\x0\xcf\x0\x10\x1\xd1\x0\x9\x3\xd3\x0\xd4\x0\xa0\x1\xd6\x0\xd7\x0\xd8\x0\xd9\x0\xda\x0\xdb\x0\xdc\x0\xaf\x1\x3\x3\xdf\x0\xe0\x0\xe1\x0\xe2\x0\x3\x1\xe4\x0\xe5\x0\xe6\x0\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\x1\x3\xed\x0\xee\x0\xef\x0\x11\x1\xf1\x0\x23\x3\xf3\x0\xf4\x0\xa1\x1\xf6\x0\xf7\x0\xf8\x0\xf9\x0\xfa\x0\xfb\x0\xfc\x0\xb0\x1\xab\x20\xff\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x0\x2\x40\x2\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x80\x2\xc0\x1\xc0\x2\xc0\x1\x0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\x0\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\x0\xcd\xce\xcf\x0\xd1\x0\xd3\xd4\x0\xd6\xd7\xd8\xd9\xda\xdb\xdc\x0\x0\xdf\xe0\xe1\xe2\x0\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\x0\xed\xee\xef\x0\xf1\x0\xf3\xf4\x0\xf6\xf7\xf8\xf9\xfa\xfb\xfc\x0\x0\xff\x0\x0\xc3\xe3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd5\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdd\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcc\xec\x0\xde\x0\x0\x0\x0\x0\xd2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"# + , encoderMax = '\8482' + } + + } + ) + + , + (437, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\xec\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\xff\x0\xd6\x0\xdc\x0\xa2\x0\xa3\x0\xa5\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x9b\x9c\x0\x9d\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\xaf\xac\xab\x0\xa8\x0\x0\x0\x0\x8e\x8f\x92\x80\x0\x90\x0\x0\x0\x0\x0\x0\x0\xa5\x0\x0\x0\x0\x99\x0\x0\x0\x0\x0\x9a\x0\x0\xe1\x85\xa0\x83\x0\x84\x86\x91\x87\x8a\x82\x88\x89\x8d\xa1\x8c\x8b\x0\xa4\x95\xa2\x93\x0\x94\xf6\x0\x97\xa3\x96\x81\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (500, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\xa0\x0\xe2\x0\xe4\x0\xe0\x0\xe1\x0\xe3\x0\xe5\x0\xe7\x0\xf1\x0\x5b\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x21\x0\x26\x0\xe9\x0\xea\x0\xeb\x0\xe8\x0\xed\x0\xee\x0\xef\x0\xec\x0\xdf\x0\x5d\x0\x24\x0\x2a\x0\x29\x0\x3b\x0\x5e\x0\x2d\x0\x2f\x0\xc2\x0\xc4\x0\xc0\x0\xc1\x0\xc3\x0\xc5\x0\xc7\x0\xd1\x0\xa6\x0\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xf8\x0\xc9\x0\xca\x0\xcb\x0\xc8\x0\xcd\x0\xce\x0\xcf\x0\xcc\x0\x60\x0\x3a\x0\x23\x0\x40\x0\x27\x0\x3d\x0\x22\x0\xd8\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xab\x0\xbb\x0\xf0\x0\xfd\x0\xfe\x0\xb1\x0\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xaa\x0\xba\x0\xe6\x0\xb8\x0\xc6\x0\xa4\x0\xb5\x0\x7e\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xa1\x0\xbf\x0\xd0\x0\xdd\x0\xde\x0\xae\x0\xa2\x0\xa3\x0\xa5\x0\xb7\x0\xa9\x0\xa7\x0\xb6\x0\xbc\x0\xbd\x0\xbe\x0\xac\x0\x7c\x0\xaf\x0\xa8\x0\xb4\x0\xd7\x0\x7b\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xf4\x0\xf6\x0\xf2\x0\xf3\x0\xf5\x0\x7d\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb9\x0\xfb\x0\xfc\x0\xf9\x0\xfa\x0\xff\x0\x5c\x0\xf7\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xd4\x0\xd6\x0\xd2\x0\xd3\x0\xd5\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xdb\x0\xdc\x0\xd9\x0\xda\x0\x9f\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f\x40\x4f\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\x4a\xe0\x5a\x5f\x6d\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\xbb\xd0\xa1\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x41\xaa\xb0\xb1\x9f\xb2\x6a\xb5\xbd\xb4\x9a\x8a\xba\xca\xaf\xbc\x90\x8f\xea\xfa\xbe\xa0\xb6\xb3\x9d\xda\x9b\x8b\xb7\xb8\xb9\xab\x64\x65\x62\x66\x63\x67\x9e\x68\x74\x71\x72\x73\x78\x75\x76\x77\xac\x69\xed\xee\xeb\xef\xec\xbf\x80\xfd\xfe\xfb\xfc\xad\xae\x59\x44\x45\x42\x46\x43\x47\x9c\x48\x54\x51\x52\x53\x58\x55\x56\x57\x8c\x49\xcd\xce\xcb\xcf\xcc\xe1\x70\xdd\xde\xdb\xdc\x8d\x8e\xdf"# + , encoderMax = '\255' + } + + } + ) + + , + (737, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\x98\x3\x99\x3\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x9e\x3\x9f\x3\xa0\x3\xa1\x3\xa3\x3\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xb1\x3\xb2\x3\xb3\x3\xb4\x3\xb5\x3\xb6\x3\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc3\x3\xc2\x3\xc4\x3\xc5\x3\xc6\x3\xc7\x3\xc8\x3\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xc9\x3\xac\x3\xad\x3\xae\x3\xca\x3\xaf\x3\xcc\x3\xcd\x3\xcb\x3\xce\x3\x86\x3\x88\x3\x89\x3\x8a\x3\x8c\x3\x8e\x3\x8f\x3\xb1\x0\x65\x22\x64\x22\xaa\x3\xab\x3\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf8\xf1\xfd\x0\x0\x0\x0\xfa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf6\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xea\x0\xeb\xec\xed\x0\xee\x0\xef\xf0\x0\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x0\x91\x92\x93\x94\x95\x96\x97\xf4\xf5\xe1\xe2\xe3\xe5\x0\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xaa\xa9\xab\xac\xad\xae\xaf\xe0\xe4\xe8\xe6\xe7\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (775, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x6\x1\xfc\x0\xe9\x0\x1\x1\xe4\x0\x23\x1\xe5\x0\x7\x1\x42\x1\x13\x1\x56\x1\x57\x1\x2b\x1\x79\x1\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\x4d\x1\xf6\x0\x22\x1\xa2\x0\x5a\x1\x5b\x1\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xd7\x0\xa4\x0\x0\x1\x2a\x1\xf3\x0\x7b\x1\x7c\x1\x7a\x1\x1d\x20\xa6\x0\xa9\x0\xae\x0\xac\x0\xbd\x0\xbc\x0\x41\x1\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x4\x1\xc\x1\x18\x1\x16\x1\x63\x25\x51\x25\x57\x25\x5d\x25\x2e\x1\x60\x1\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x72\x1\x6a\x1\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x7d\x1\x5\x1\xd\x1\x19\x1\x17\x1\x2f\x1\x61\x1\x73\x1\x6b\x1\x7e\x1\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xd3\x0\xdf\x0\x4c\x1\x43\x1\xf5\x0\xd5\x0\xb5\x0\x44\x1\x36\x1\x37\x1\x3b\x1\x3c\x1\x46\x1\x12\x1\x45\x1\x19\x20\xad\x0\xb1\x0\x1c\x20\xbe\x0\xb6\x0\xa7\x0\xf7\x0\x1e\x20\xb0\x0\x19\x22\xb7\x0\xb9\x0\xb3\x0\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x40\x2\x80\x2\xc0\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x96\x9c\x9f\x0\xa7\xf5\x0\xa8\x0\xae\xaa\xf0\xa9\x0\xf8\xf1\xfd\xfc\x0\xe6\xf4\xfa\x0\xfb\x0\xaf\xac\xab\xf3\x0\x0\x0\x0\x0\x8e\x8f\x92\x0\x0\x90\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe0\x0\xe5\x99\x9e\x9d\x0\x0\x0\x9a\x0\x0\xe1\x0\x0\x0\x0\x84\x86\x91\x0\x0\x82\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa2\x0\xe4\x94\xf6\x9b\x0\x0\x0\x81\x0\x0\x0\xa0\x83\x0\x0\xb5\xd0\x80\x87\x0\x0\x0\x0\xb6\xd1\x0\x0\x0\x0\xed\x89\x0\x0\xb8\xd3\xb7\xd2\x0\x0\x0\x0\x0\x0\x0\x0\x95\x85\x0\x0\x0\x0\x0\x0\xa1\x8c\x0\x0\xbd\xd4\x0\x0\x0\x0\x0\x0\xe8\xe9\x0\x0\x0\xea\xeb\x0\x0\x0\x0\xad\x88\xe3\xe7\xee\xec\x0\x0\x0\x0\x0\xe2\x93\x0\x0\x0\x0\x0\x0\x0\x0\x8a\x8b\x0\x0\x97\x98\x0\x0\x0\x0\xbe\xd5\x0\x0\x0\x0\x0\x0\x0\x0\xc7\xd7\x0\x0\x0\x0\x0\x0\xc6\xd6\x0\x0\x0\x0\x0\x8d\xa5\xa3\xa4\xcf\xd8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\xf2\xa6\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (850, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\xec\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\xff\x0\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xd7\x0\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\xae\x0\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\xc1\x0\xc2\x0\xc0\x0\xa9\x0\x63\x25\x51\x25\x57\x25\x5d\x25\xa2\x0\xa5\x0\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\xe3\x0\xc3\x0\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\xf0\x0\xd0\x0\xca\x0\xcb\x0\xc8\x0\x31\x1\xcd\x0\xce\x0\xcf\x0\x18\x25\xc\x25\x88\x25\x84\x25\xa6\x0\xcc\x0\x80\x25\xd3\x0\xdf\x0\xd4\x0\xd2\x0\xf5\x0\xd5\x0\xb5\x0\xfe\x0\xde\x0\xda\x0\xdb\x0\xd9\x0\xfd\x0\xdd\x0\xaf\x0\xb4\x0\xad\x0\xb1\x0\x17\x20\xbe\x0\xb6\x0\xa7\x0\xf7\x0\xb8\x0\xb0\x0\xa8\x0\xb7\x0\xb9\x0\xb3\x0\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\xc0\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x0\x2\x40\x2\x80\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\xbd\x9c\xcf\xbe\xdd\xf5\xf9\xb8\xa6\xae\xaa\xf0\xa9\xee\xf8\xf1\xfd\xfc\xef\xe6\xf4\xfa\xf7\xfb\xa7\xaf\xac\xab\xf3\xa8\xb7\xb5\xb6\xc7\x8e\x8f\x92\x80\xd4\x90\xd2\xd3\xde\xd6\xd7\xd8\xd1\xa5\xe3\xe0\xe2\xe5\x99\x9e\x9d\xeb\xe9\xea\x9a\xed\xe8\xe1\x85\xa0\x83\xc6\x84\x86\x91\x87\x8a\x82\x88\x89\x8d\xa1\x8c\x8b\xd0\xa4\x95\xa2\x93\xe4\x94\xf6\x9b\x97\xa3\x96\x81\xec\xe7\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (852, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\x6f\x1\x7\x1\xe7\x0\x42\x1\xeb\x0\x50\x1\x51\x1\xee\x0\x79\x1\xc4\x0\x6\x1\xc9\x0\x39\x1\x3a\x1\xf4\x0\xf6\x0\x3d\x1\x3e\x1\x5a\x1\x5b\x1\xd6\x0\xdc\x0\x64\x1\x65\x1\x41\x1\xd7\x0\xd\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\x4\x1\x5\x1\x7d\x1\x7e\x1\x18\x1\x19\x1\xac\x0\x7a\x1\xc\x1\x5f\x1\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\xc1\x0\xc2\x0\x1a\x1\x5e\x1\x63\x25\x51\x25\x57\x25\x5d\x25\x7b\x1\x7c\x1\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x2\x1\x3\x1\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\x11\x1\x10\x1\xe\x1\xcb\x0\xf\x1\x47\x1\xcd\x0\xce\x0\x1b\x1\x18\x25\xc\x25\x88\x25\x84\x25\x62\x1\x6e\x1\x80\x25\xd3\x0\xdf\x0\xd4\x0\x43\x1\x44\x1\x48\x1\x60\x1\x61\x1\x54\x1\xda\x0\x55\x1\x70\x1\xfd\x0\xdd\x0\x63\x1\xb4\x0\xad\x0\xdd\x2\xdb\x2\xc7\x2\xd8\x2\xa7\x0\xf7\x0\xb8\x0\xb0\x0\xa8\x0\xd9\x2\x71\x1\x58\x1\x59\x1\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x40\x2\x80\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\xcf\x0\x0\xf5\xf9\x0\x0\xae\xaa\xf0\x0\x0\xf8\x0\x0\x0\xef\x0\x0\x0\xf7\x0\x0\xaf\x0\x0\x0\x0\x0\xb5\xb6\x0\x8e\x0\x0\x80\x0\x90\x0\xd3\x0\xd6\xd7\x0\x0\x0\x0\xe0\xe2\x0\x99\x9e\x0\x0\xe9\x0\x9a\xed\x0\xe1\x0\xa0\x83\x0\x84\x0\x0\x87\x0\x82\x0\x89\x0\xa1\x8c\x0\x0\x0\x0\xa2\x93\x0\x94\xf6\x0\x0\xa3\x0\x81\xec\x0\x0\x0\x0\xc6\xc7\xa4\xa5\x8f\x86\x0\x0\x0\x0\xac\x9f\xd2\xd4\xd1\xd0\x0\x0\x0\x0\x0\x0\xa8\xa9\xb7\xd8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x91\x92\x0\x0\x95\x96\x0\x0\x9d\x88\xe3\xe4\x0\x0\xd5\xe5\x0\x0\x0\x0\x0\x0\x0\x8a\x8b\x0\x0\xe8\xea\x0\x0\xfc\xfd\x97\x98\x0\x0\xb8\xad\xe6\xe7\xdd\xee\x9b\x9c\x0\x0\x0\x0\x0\x0\x0\x0\xde\x85\xeb\xfb\x0\x0\x0\x0\x0\x0\x0\x8d\xab\xbd\xbe\xa6\xa7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xfa\x0\xf2\x0\xf1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (855, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x52\x4\x2\x4\x53\x4\x3\x4\x51\x4\x1\x4\x54\x4\x4\x4\x55\x4\x5\x4\x56\x4\x6\x4\x57\x4\x7\x4\x58\x4\x8\x4\x59\x4\x9\x4\x5a\x4\xa\x4\x5b\x4\xb\x4\x5c\x4\xc\x4\x5e\x4\xe\x4\x5f\x4\xf\x4\x4e\x4\x2e\x4\x4a\x4\x2a\x4\x30\x4\x10\x4\x31\x4\x11\x4\x46\x4\x26\x4\x34\x4\x14\x4\x35\x4\x15\x4\x44\x4\x24\x4\x33\x4\x13\x4\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x45\x4\x25\x4\x38\x4\x18\x4\x63\x25\x51\x25\x57\x25\x5d\x25\x39\x4\x19\x4\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x3a\x4\x1a\x4\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\x3b\x4\x1b\x4\x3c\x4\x1c\x4\x3d\x4\x1d\x4\x3e\x4\x1e\x4\x3f\x4\x18\x25\xc\x25\x88\x25\x84\x25\x1f\x4\x4f\x4\x80\x25\x2f\x4\x40\x4\x20\x4\x41\x4\x21\x4\x42\x4\x22\x4\x43\x4\x23\x4\x36\x4\x16\x4\x32\x4\x12\x4\x4c\x4\x2c\x4\x16\x21\xad\x0\x4b\x4\x2b\x4\x37\x4\x17\x4\x48\x4\x28\x4\x4d\x4\x2d\x4\x49\x4\x29\x4\x47\x4\x27\x4\xa7\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\x0\x2\x40\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\xcf\x0\x0\xfd\x0\x0\x0\xae\x0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xaf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x85\x81\x83\x87\x89\x8b\x8d\x8f\x91\x93\x95\x97\x0\x99\x9b\xa1\xa3\xec\xad\xa7\xa9\xea\xf4\xb8\xbe\xc7\xd1\xd3\xd5\xd7\xdd\xe2\xe4\xe6\xe8\xab\xb6\xa5\xfc\xf6\xfa\x9f\xf2\xee\xf8\x9d\xe0\xa0\xa2\xeb\xac\xa6\xa8\xe9\xf3\xb7\xbd\xc6\xd0\xd2\xd4\xd6\xd8\xe1\xe3\xe5\xe7\xaa\xb5\xa4\xfb\xf5\xf9\x9e\xf1\xed\xf7\x9c\xde\x0\x84\x80\x82\x86\x88\x8a\x8c\x8e\x90\x92\x94\x96\x0\x98\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (857, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\x31\x1\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\x30\x1\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\x5e\x1\x5f\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\x1e\x1\x1f\x1\xbf\x0\xae\x0\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\xc1\x0\xc2\x0\xc0\x0\xa9\x0\x63\x25\x51\x25\x57\x25\x5d\x25\xa2\x0\xa5\x0\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\xe3\x0\xc3\x0\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\xba\x0\xaa\x0\xca\x0\xcb\x0\xc8\x0\x0\x0\xcd\x0\xce\x0\xcf\x0\x18\x25\xc\x25\x88\x25\x84\x25\xa6\x0\xcc\x0\x80\x25\xd3\x0\xdf\x0\xd4\x0\xd2\x0\xf5\x0\xd5\x0\xb5\x0\x0\x0\xd7\x0\xda\x0\xdb\x0\xd9\x0\xec\x0\xff\x0\xaf\x0\xb4\x0\xad\x0\xb1\x0\x0\x0\xbe\x0\xb6\x0\xa7\x0\xf7\x0\xb8\x0\xb0\x0\xa8\x0\xb7\x0\xb9\x0\xb3\x0\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x0\x2\x40\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\xbd\x9c\xcf\xbe\xdd\xf5\xf9\xb8\xd1\xae\xaa\xf0\xa9\xee\xf8\xf1\xfd\xfc\xef\xe6\xf4\xfa\xf7\xfb\xd0\xaf\xac\xab\xf3\xa8\xb7\xb5\xb6\xc7\x8e\x8f\x92\x80\xd4\x90\xd2\xd3\xde\xd6\xd7\xd8\x0\xa5\xe3\xe0\xe2\xe5\x99\xe8\x9d\xeb\xe9\xea\x9a\x0\x0\xe1\x85\xa0\x83\xc6\x84\x86\x91\x87\x8a\x82\x88\x89\xec\xa1\x8c\x8b\x0\xa4\x95\xa2\x93\xe4\x94\xf6\x9b\x97\xa3\x96\x81\x0\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa6\xa7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x8d\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (860, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe3\x0\xe0\x0\xc1\x0\xe7\x0\xea\x0\xca\x0\xe8\x0\xcd\x0\xd4\x0\xec\x0\xc3\x0\xc2\x0\xc9\x0\xc0\x0\xc8\x0\xf4\x0\xf5\x0\xf2\x0\xda\x0\xf9\x0\xcc\x0\xd5\x0\xdc\x0\xa2\x0\xa3\x0\xd9\x0\xa7\x20\xd3\x0\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\xd2\x0\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x80\x2\x0\x1\x0\x1\xc0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x3\x40\x3\x80\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x9b\x9c\x0\x0\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\xaf\xac\xab\x0\xa8\x91\x86\x8f\x8e\x0\x0\x0\x80\x92\x90\x89\x0\x98\x8b\x0\x0\x0\xa5\xa9\x9f\x8c\x99\x0\x0\x0\x9d\x96\x0\x9a\x0\x0\xe1\x85\xa0\x83\x84\x0\x0\x0\x87\x8a\x82\x88\x0\x8d\xa1\x0\x0\x0\xa4\x95\xa2\x93\x94\x0\xf6\x0\x97\xa3\x0\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (861, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xd0\x0\xf0\x0\xde\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xfe\x0\xfb\x0\xdd\x0\xfd\x0\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xc1\x0\xcd\x0\xd3\x0\xda\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x0\x9c\x0\x0\x0\x0\x0\x0\x0\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\x0\xaf\xac\xab\x0\xa8\x0\xa4\x0\x0\x8e\x8f\x92\x80\x0\x90\x0\x0\x0\xa5\x0\x0\x8b\x0\x0\xa6\x0\x0\x99\x0\x9d\x0\xa7\x0\x9a\x97\x8d\xe1\x85\xa0\x83\x0\x84\x86\x91\x87\x8a\x82\x88\x89\x0\xa1\x0\x0\x8c\x0\x0\xa2\x93\x0\x94\xf6\x9b\x0\xa3\x96\x81\x98\x95\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (862, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xd0\x5\xd1\x5\xd2\x5\xd3\x5\xd4\x5\xd5\x5\xd6\x5\xd7\x5\xd8\x5\xd9\x5\xda\x5\xdb\x5\xdc\x5\xdd\x5\xde\x5\xdf\x5\xe0\x5\xe1\x5\xe2\x5\xe3\x5\xe4\x5\xe5\x5\xe6\x5\xe7\x5\xe8\x5\xe9\x5\xea\x5\xa2\x0\xa3\x0\xa5\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x80\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x2\x0\x3\x0\x1\x0\x1\x40\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x3\xc0\x3\x0\x4"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x9b\x9c\x0\x9d\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\xaf\xac\xab\x0\xa8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe1\x0\xa0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\x0\x0\x0\xa4\x0\xa2\x0\x0\x0\xf6\x0\x0\xa3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (863, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xc2\x0\xe0\x0\xb6\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\x17\x20\xc0\x0\xa7\x0\xc9\x0\xc8\x0\xca\x0\xf4\x0\xcb\x0\xcf\x0\xfb\x0\xf9\x0\xa4\x0\xd4\x0\xdc\x0\xa2\x0\xa3\x0\xd9\x0\xdb\x0\x92\x1\xa6\x0\xb4\x0\xf3\x0\xfa\x0\xa8\x0\xb8\x0\xb3\x0\xaf\x0\xce\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xbe\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x9b\x9c\x98\x0\xa0\x8f\xa4\x0\x0\xae\xaa\x0\x0\xa7\xf8\xf1\xfd\xa6\xa1\xe6\x86\xfa\xa5\x0\x0\xaf\xac\xab\xad\x0\x8e\x0\x84\x0\x0\x0\x0\x80\x91\x90\x92\x94\x0\x0\xa8\x95\x0\x0\x0\x0\x99\x0\x0\x0\x0\x9d\x0\x9e\x9a\x0\x0\xe1\x85\x0\x83\x0\x0\x0\x0\x87\x8a\x82\x88\x89\x0\x0\x8c\x8b\x0\x0\x0\xa2\x93\x0\x0\xf6\x0\x97\xa3\x96\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8d\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (864, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x6a\x6\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xb0\x0\xb7\x0\x19\x22\x1a\x22\x92\x25\x0\x25\x2\x25\x3c\x25\x24\x25\x2c\x25\x1c\x25\x34\x25\x10\x25\xc\x25\x14\x25\x18\x25\xb2\x3\x1e\x22\xc6\x3\xb1\x0\xbd\x0\xbc\x0\x48\x22\xab\x0\xbb\x0\xf7\xfe\xf8\xfe\x0\x0\x0\x0\xfb\xfe\xfc\xfe\x0\x0\xa0\x0\xad\x0\x82\xfe\xa3\x0\xa4\x0\x84\xfe\x0\x0\x0\x0\x8e\xfe\x8f\xfe\x95\xfe\x99\xfe\xc\x6\x9d\xfe\xa1\xfe\xa5\xfe\x60\x6\x61\x6\x62\x6\x63\x6\x64\x6\x65\x6\x66\x6\x67\x6\x68\x6\x69\x6\xd1\xfe\x1b\x6\xb1\xfe\xb5\xfe\xb9\xfe\x1f\x6\xa2\x0\x80\xfe\x81\xfe\x83\xfe\x85\xfe\xca\xfe\x8b\xfe\x8d\xfe\x91\xfe\x93\xfe\x97\xfe\x9b\xfe\x9f\xfe\xa3\xfe\xa7\xfe\xa9\xfe\xab\xfe\xad\xfe\xaf\xfe\xb3\xfe\xb7\xfe\xbb\xfe\xbf\xfe\xc1\xfe\xc5\xfe\xcb\xfe\xcf\xfe\xa6\x0\xac\x0\xf7\x0\xd7\x0\xc9\xfe\x40\x6\xd3\xfe\xd7\xfe\xdb\xfe\xdf\xfe\xe3\xfe\xe7\xfe\xeb\xfe\xed\xfe\xef\xfe\xf3\xfe\xbd\xfe\xcc\xfe\xce\xfe\xcd\xfe\xe1\xfe\x7d\xfe\x51\x6\xe5\xfe\xe9\xfe\xec\xfe\xf0\xfe\xf2\xfe\xd0\xfe\xd5\xfe\xf5\xfe\xf6\xfe\xdd\xfe\xd9\xfe\xf1\xfe\xa0\x25\x0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x80\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x2\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x0\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xc0\xa3\xa4\x0\xdb\x0\x0\x0\x0\x97\xdc\xa1\x0\x0\x80\x93\x0\x0\x0\x0\x0\x81\x0\x0\x0\x98\x95\x94\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xde\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x90\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x92\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xac\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xbb\x0\x0\x0\xbf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\x25\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x82\x83\x0\x0\x0\x91\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x85\x0\x86\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8d\x0\x0\x0\x8c\x0\x0\x0\x8e\x0\x0\x0\x8f\x0\x0\x0\x8a\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x8b\x0\x0\x0\x0\x0\x0\x0\x87\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x84\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xc1\xc2\xa2\xc3\xa5\xc4\x0\x0\x0\x0\x0\xc6\x0\xc7\xa8\xa9\x0\xc8\x0\xc9\x0\xaa\x0\xca\x0\xab\x0\xcb\x0\xad\x0\xcc\x0\xae\x0\xcd\x0\xaf\x0\xce\x0\xcf\x0\xd0\x0\xd1\x0\xd2\x0\xbc\x0\xd3\x0\xbd\x0\xd4\x0\xbe\x0\xd5\x0\xeb\x0\xd6\x0\xd7\x0\x0\x0\xd8\x0\x0\x0\xdf\xc5\xd9\xec\xee\xed\xda\xf7\xba\x0\xe1\x0\xf8\x0\xe2\x0\xfc\x0\xe3\x0\xfb\x0\xe4\x0\xef\x0\xe5\x0\xf2\x0\xe6\x0\xf3\x0\xe7\xf4\xe8\x0\xe9\xf5\xfd\xf6\xea\x0\xf9\xfa\x99\x9a\x0\x0\x9d\x9e"# + , encoderMax = '\65276' + } + + } + ) + + , + (865, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\xec\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\xff\x0\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xa4\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x0\x9c\xaf\x0\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\x0\xac\xab\x0\xa8\x0\x0\x0\x0\x8e\x8f\x92\x80\x0\x90\x0\x0\x0\x0\x0\x0\x0\xa5\x0\x0\x0\x0\x99\x0\x9d\x0\x0\x0\x9a\x0\x0\xe1\x85\xa0\x83\x0\x84\x86\x91\x87\x8a\x82\x88\x89\x8d\xa1\x8c\x8b\x0\xa4\x95\xa2\x93\x0\x94\xf6\x9b\x97\xa3\x96\x81\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (866, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x10\x4\x11\x4\x12\x4\x13\x4\x14\x4\x15\x4\x16\x4\x17\x4\x18\x4\x19\x4\x1a\x4\x1b\x4\x1c\x4\x1d\x4\x1e\x4\x1f\x4\x20\x4\x21\x4\x22\x4\x23\x4\x24\x4\x25\x4\x26\x4\x27\x4\x28\x4\x29\x4\x2a\x4\x2b\x4\x2c\x4\x2d\x4\x2e\x4\x2f\x4\x30\x4\x31\x4\x32\x4\x33\x4\x34\x4\x35\x4\x36\x4\x37\x4\x38\x4\x39\x4\x3a\x4\x3b\x4\x3c\x4\x3d\x4\x3e\x4\x3f\x4\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\x40\x4\x41\x4\x42\x4\x43\x4\x44\x4\x45\x4\x46\x4\x47\x4\x48\x4\x49\x4\x4a\x4\x4b\x4\x4c\x4\x4d\x4\x4e\x4\x4f\x4\x1\x4\x51\x4\x4\x4\x54\x4\x7\x4\x57\x4\xe\x4\x5e\x4\xb0\x0\x19\x22\xb7\x0\x1a\x22\x16\x21\xa4\x0\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x2\x40\x2\x80\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf8\x0\x0\x0\x0\x0\x0\xfa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf2\x0\x0\xf4\x0\x0\x0\x0\x0\x0\xf6\x0\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\x0\xf1\x0\x0\xf3\x0\x0\xf5\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (869, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x86\x3\x0\x0\xb7\x0\xac\x0\xa6\x0\x18\x20\x19\x20\x88\x3\x15\x20\x89\x3\x8a\x3\xaa\x3\x8c\x3\x0\x0\x0\x0\x8e\x3\xab\x3\xa9\x0\x8f\x3\xb2\x0\xb3\x0\xac\x3\xa3\x0\xad\x3\xae\x3\xaf\x3\xca\x3\x90\x3\xcc\x3\xcd\x3\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\xbd\x0\x98\x3\x99\x3\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x63\x25\x51\x25\x57\x25\x5d\x25\x9e\x3\x9f\x3\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\xa0\x3\xa1\x3\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa3\x3\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xb1\x3\xb2\x3\xb3\x3\x18\x25\xc\x25\x88\x25\x84\x25\xb4\x3\xb5\x3\x80\x25\xb6\x3\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc3\x3\xc2\x3\xc4\x3\x84\x3\xad\x0\xb1\x0\xc5\x3\xc6\x3\xc7\x3\xa7\x0\xc8\x3\x85\x3\xb0\x0\xa8\x0\xc9\x3\xcb\x3\xb0\x3\xce\x3\xa0\x25\xa0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\x0\x2\x40\x2"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x9c\x0\x0\x8a\xf5\xf9\x97\x0\xae\x89\xf0\x0\x0\xf8\xf1\x99\x9a\x0\x0\x0\x88\x0\x0\x0\xaf\x0\xab\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\xf7\x86\x0\x8d\x8f\x90\x0\x92\x0\x95\x98\xa1\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xac\xad\xb5\xb6\xb7\xb8\xbd\xbe\xc6\xc7\x0\xcf\xd0\xd1\xd2\xd3\xd4\xd5\x91\x96\x9b\x9d\x9e\x9f\xfc\xd6\xd7\xd8\xdd\xde\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xed\xec\xee\xf2\xf3\xf4\xf6\xfa\xa0\xfb\xa2\xa3\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8e\x0\x0\x8b\x8c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"# + , encoderMax = '\9632' + } + + } + ) + + , + (874, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x0\x0\x0\x0\x0\x0\x26\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x1\xe\x2\xe\x3\xe\x4\xe\x5\xe\x6\xe\x7\xe\x8\xe\x9\xe\xa\xe\xb\xe\xc\xe\xd\xe\xe\xe\xf\xe\x10\xe\x11\xe\x12\xe\x13\xe\x14\xe\x15\xe\x16\xe\x17\xe\x18\xe\x19\xe\x1a\xe\x1b\xe\x1c\xe\x1d\xe\x1e\xe\x1f\xe\x20\xe\x21\xe\x22\xe\x23\xe\x24\xe\x25\xe\x26\xe\x27\xe\x28\xe\x29\xe\x2a\xe\x2b\xe\x2c\xe\x2d\xe\x2e\xe\x2f\xe\x30\xe\x31\xe\x32\xe\x33\xe\x34\xe\x35\xe\x36\xe\x37\xe\x38\xe\x39\xe\x3a\xe\x0\x0\x0\x0\x0\x0\x0\x0\x3f\xe\x40\xe\x41\xe\x42\xe\x43\xe\x44\xe\x45\xe\x46\xe\x47\xe\x48\xe\x49\xe\x4a\xe\x4b\xe\x4c\xe\x4d\xe\x4e\xe\x4f\xe\x50\xe\x51\xe\x52\xe\x53\xe\x54\xe\x55\xe\x56\xe\x57\xe\x58\xe\x59\xe\x5a\xe\x5b\xe\x0\x0\x0\x0\x0\x0\x0\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x1"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\x0\x0\x0\x0\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x0\x0\x93\x94\x0\x0\x0\x0\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80"# + , encoderMax = '\8364' + } + + } + ) + + , + (875, SingleByteCP { + decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\x98\x3\x99\x3\x5b\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x21\x0\x26\x0\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x9e\x3\x9f\x3\xa0\x3\xa1\x3\xa3\x3\x5d\x0\x24\x0\x2a\x0\x29\x0\x3b\x0\x5e\x0\x2d\x0\x2f\x0\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xaa\x3\xab\x3\x7c\x0\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xa8\x0\x86\x3\x88\x3\x89\x3\xa0\x0\x8a\x3\x8c\x3\x8e\x3\x8f\x3\x60\x0\x3a\x0\x23\x0\x40\x0\x27\x0\x3d\x0\x22\x0\x85\x3\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xb1\x3\xb2\x3\xb3\x3\xb4\x3\xb5\x3\xb6\x3\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xb4\x0\x7e\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc3\x3\xa3\x0\xac\x3\xad\x3\xae\x3\xca\x3\xaf\x3\xcc\x3\xcd\x3\xcb\x3\xce\x3\xc2\x3\xc4\x3\xc5\x3\xc6\x3\xc7\x3\xc8\x3\x7b\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xc9\x3\x90\x3\xb0\x3\x18\x20\x15\x20\x7d\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb1\x0\xbd\x0\x1a\x0\x87\x3\x19\x20\xa6\x0\x5c\x0\x1a\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xa7\x0\x1a\x0\x1a\x0\xab\x0\xac\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xa9\x0\x1a\x0\x1a\x0\xbb\x0\x9f\x0"# + , encoderArray = + CompactArray { + encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1"# + , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\xfd\x27\x1c\x1d\x1e\x1f\x40\x4f\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\x4a\xe0\x5a\x5f\x6d\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\x6a\xd0\xa1\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x74\x0\x0\xb0\x0\x0\xdf\xeb\x70\xfb\x0\xee\xef\xca\x0\x0\x90\xda\xea\xfa\xa0\x0\x0\x0\x0\x0\x0\xfe\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x71\xdd\x72\x73\x75\x0\x76\x0\x77\x78\xcc\x41\x42\x43\x44\x45\x46\x47\x48\x49\x51\x52\x53\x54\x55\x56\x57\x58\x0\x59\x62\x63\x64\x65\x66\x67\x68\x69\xb1\xb2\xb3\xb5\xcd\x8a\x8b\x8c\x8d\x8e\x8f\x9a\x9b\x9c\x9d\x9e\x9f\xaa\xab\xac\xad\xae\xba\xaf\xbb\xbc\xbd\xbe\xbf\xcb\xb4\xb8\xb6\xb7\xb9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcf\x0\x0\xce\xde"# + , encoderMax = '\8217' + } + + } + ) + ] diff --git a/lib/base/src/GHC/IO/Encoding/Iconv.hs b/lib/base/src/GHC/IO/Encoding/Iconv.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/Iconv.hs @@ -0,0 +1,217 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Iconv +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This module provides text encoding/decoding using iconv +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO.Encoding.Iconv ( +#if !defined(mingw32_HOST_OS) + mkTextEncoding, + latin1, + utf8, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding +#endif + ) where + + +#if !defined(mingw32_HOST_OS) + +import Foreign +import Foreign.C +import Data.Maybe +import GHC.Base +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Num +import GHC.Show +import GHC.Real +import System.Posix.Internals + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False + +iconv_trace :: String -> IO () +iconv_trace s + | c_DEBUG_DUMP = puts s + | otherwise = return () + +puts :: String -> IO () +puts s = do _ <- withCStringLen (s ++ "\n") $ \(p, len) -> + c_write 1 (castPtr p) (fromIntegral len) + return () + +-- ----------------------------------------------------------------------------- +-- iconv encoders/decoders + +{-# NOINLINE latin1 #-} +latin1 :: TextEncoding +latin1 = unsafePerformIO (mkTextEncoding "Latin1") + +{-# NOINLINE utf8 #-} +utf8 :: TextEncoding +utf8 = unsafePerformIO (mkTextEncoding "UTF8") + +{-# NOINLINE utf16 #-} +utf16 :: TextEncoding +utf16 = unsafePerformIO (mkTextEncoding "UTF16") + +{-# NOINLINE utf16le #-} +utf16le :: TextEncoding +utf16le = unsafePerformIO (mkTextEncoding "UTF16LE") + +{-# NOINLINE utf16be #-} +utf16be :: TextEncoding +utf16be = unsafePerformIO (mkTextEncoding "UTF16BE") + +{-# NOINLINE utf32 #-} +utf32 :: TextEncoding +utf32 = unsafePerformIO (mkTextEncoding "UTF32") + +{-# NOINLINE utf32le #-} +utf32le :: TextEncoding +utf32le = unsafePerformIO (mkTextEncoding "UTF32LE") + +{-# NOINLINE utf32be #-} +utf32be :: TextEncoding +utf32be = unsafePerformIO (mkTextEncoding "UTF32BE") + +{-# NOINLINE localeEncoding #-} +localeEncoding :: TextEncoding +localeEncoding = unsafePerformIO $ do +#if HAVE_LANGINFO_H + cstr <- c_localeEncoding -- use nl_langinfo(CODESET) to get the encoding + -- if we have it + r <- peekCString cstr + mkTextEncoding r +#else + mkTextEncoding "" -- GNU iconv accepts "" to mean the -- locale encoding. +#endif + +-- We hope iconv_t is a storable type. It should be, since it has at least the +-- value -1, which is a possible return value from iconv_open. +type IConv = CLong -- ToDo: (#type iconv_t) + +foreign import ccall unsafe "iconv_open" + hs_iconv_open :: CString -> CString -> IO IConv + +foreign import ccall unsafe "iconv_close" + hs_iconv_close :: IConv -> IO CInt + +foreign import ccall unsafe "iconv" + hs_iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize + -> IO CSize + +foreign import ccall unsafe "localeEncoding" + c_localeEncoding :: IO CString + +haskellChar :: String +#ifdef WORDS_BIGENDIAN +haskellChar | charSize == 2 = "UTF-16BE" + | otherwise = "UTF-32BE" +#else +haskellChar | charSize == 2 = "UTF-16LE" + | otherwise = "UTF-32LE" +#endif + +char_shift :: Int +char_shift | charSize == 2 = 1 + | otherwise = 2 + +mkTextEncoding :: String -> IO TextEncoding +mkTextEncoding charset = do + return (TextEncoding { + mkTextDecoder = newIConv charset haskellChar iconvDecode, + mkTextEncoder = newIConv haskellChar charset iconvEncode}) + +newIConv :: String -> String + -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) + -> IO (BufferCodec a b ()) +newIConv from to fn = + withCString from $ \ from_str -> + withCString to $ \ to_str -> do + iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str + let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt + return BufferCodec{ + encode = fn iconvt, + close = iclose, + -- iconv doesn't supply a way to save/restore the state + getState = return (), + setState = const $ return () + } + +iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem + -> IO (Buffer Word8, Buffer CharBufElem) +iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift + +iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8 + -> IO (Buffer CharBufElem, Buffer Word8) +iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0 + +iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int + -> IO (Buffer a, Buffer b) +iconvRecode iconv_t + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } iscale + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } oscale + = do + iconv_trace ("haskelChar=" ++ show haskellChar) + iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input)) + iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output)) + withRawBuffer iraw $ \ piraw -> do + withRawBuffer oraw $ \ poraw -> do + with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do + with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do + with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do + with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do + res <- hs_iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft + new_inleft <- peek p_inleft + new_outleft <- peek p_outleft + let + new_inleft' = fromIntegral new_inleft `shiftR` iscale + new_outleft' = fromIntegral new_outleft `shiftR` oscale + new_input + | new_inleft == 0 = input { bufL = 0, bufR = 0 } + | otherwise = input { bufL = iw - new_inleft' } + new_output = output{ bufR = os - new_outleft' } + iconv_trace ("iconv res=" ++ show res) + iconv_trace ("iconvRecode after, input=" ++ show (summaryBuffer new_input)) + iconv_trace ("iconvRecode after, output=" ++ show (summaryBuffer new_output)) + if (res /= -1) + then do -- all input translated + return (new_input, new_output) + else do + errno <- getErrno + case errno of + e | e == eINVAL + || (e == e2BIG || e == eILSEQ) && new_inleft' /= (iw-ir) -> do + iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing)) + -- Output overflow is relatively harmless, unless + -- we made no progress at all. + -- + -- Similarly, we ignore EILSEQ unless we converted no + -- characters. Sometimes iconv reports EILSEQ for a + -- character in the input even when there is no room + -- in the output; in this case we might be about to + -- change the encoding anyway, so the following bytes + -- could very well be in a different encoding. + -- This also helps with pinpointing EILSEQ errors: we + -- don't report it until the rest of the characters in + -- the buffer have been drained. + return (new_input, new_output) + + _other -> + throwErrno "iconvRecoder" + -- illegal sequence, or some other error + +#endif /* !mingw32_HOST_OS */ diff --git a/lib/base/src/GHC/IO/Encoding/Latin1.hs b/lib/base/src/GHC/IO/Encoding/Latin1.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/Latin1.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Latin1 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-32 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.Latin1 ( + latin1, + latin1_checked, + latin1_decode, + latin1_encode, + latin1_checked_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +-- import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import Data.Maybe + +-- ----------------------------------------------------------------------------- +-- Latin1 + +latin1 :: TextEncoding +latin1 = TextEncoding { mkTextDecoder = latin1_DF, + mkTextEncoder = latin1_EF } + +latin1_DF :: IO (TextDecoder ()) +latin1_DF = + return (BufferCodec { + encode = latin1_decode, + close = return (), + getState = return (), + setState = const $ return () + }) + +latin1_EF :: IO (TextEncoder ()) +latin1_EF = + return (BufferCodec { + encode = latin1_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + +latin1_checked :: TextEncoding +latin1_checked = TextEncoding { mkTextDecoder = latin1_DF, + mkTextEncoder = latin1_checked_EF } + +latin1_checked_EF :: IO (TextEncoder ()) +latin1_checked_EF = + return (BufferCodec { + encode = latin1_checked_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + + +latin1_decode :: DecodeBuffer +latin1_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) + loop (ir+1) ow' + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +latin1_encode :: EncodeBuffer +latin1_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + writeWord8Buf oraw ow (fromIntegral (ord c)) + loop ir' (ow+1) + in + loop ir0 ow0 + +latin1_checked_encode :: EncodeBuffer +latin1_checked_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + if ord c > 0xff then invalid else do + writeWord8Buf oraw ow (fromIntegral (ord c)) + loop ir' (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_encodingError + in + loop ir0 ow0 + +ioe_encodingError :: IO a +ioe_encodingError = ioException + (IOError Nothing InvalidArgument "latin1_checked_encode" + "character is out of range for this encoding" Nothing Nothing) diff --git a/lib/base/src/GHC/IO/Encoding/Types.hs b/lib/base/src/GHC/IO/Encoding/Types.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/Types.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Types +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Types for text encoding/decoding +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.Types ( + BufferCodec(..), + TextEncoding(..), + TextEncoder, TextDecoder, + EncodeBuffer, DecodeBuffer, + ) where + +import GHC.Base +import GHC.Word +-- import GHC.IO +import GHC.IO.Buffer + +-- ----------------------------------------------------------------------------- +-- Text encoders/decoders + +data BufferCodec from to state = BufferCodec { + encode :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to), + -- ^ The @encode@ function translates elements of the buffer @from@ + -- to the buffer @to@. It should translate as many elements as possible + -- given the sizes of the buffers, including translating zero elements + -- if there is either not enough room in @to@, or @from@ does not + -- contain a complete multibyte sequence. + -- + -- @encode@ should raise an exception if, and only if, @from@ + -- begins with an illegal sequence, or the first element of @from@ + -- is not representable in the encoding of @to@. That is, if any + -- elements can be successfully translated before an error is + -- encountered, then @encode@ should translate as much as it can + -- and not throw an exception. This behaviour is used by the IO + -- library in order to report translation errors at the point they + -- actually occur, rather than when the buffer is translated. + -- + close :: IO (), + -- ^ Resources associated with the encoding may now be released. + -- The @encode@ function may not be called again after calling + -- @close@. + + getState :: IO state, + -- ^ Return the current state of the codec. + -- + -- Many codecs are not stateful, and in these case the state can be + -- represented as '()'. Other codecs maintain a state. For + -- example, UTF-16 recognises a BOM (byte-order-mark) character at + -- the beginning of the input, and remembers thereafter whether to + -- use big-endian or little-endian mode. In this case, the state + -- of the codec would include two pieces of information: whether we + -- are at the beginning of the stream (the BOM only occurs at the + -- beginning), and if not, whether to use the big or little-endian + -- encoding. + + setState :: state -> IO() + -- restore the state of the codec using the state from a previous + -- call to 'getState'. + } + +type DecodeBuffer = Buffer Word8 -> Buffer Char + -> IO (Buffer Word8, Buffer Char) + +type EncodeBuffer = Buffer Char -> Buffer Word8 + -> IO (Buffer Char, Buffer Word8) + +type TextDecoder state = BufferCodec Word8 CharBufElem state +type TextEncoder state = BufferCodec CharBufElem Word8 state + +-- | A 'TextEncoding' is a specification of a conversion scheme +-- between sequences of bytes and sequences of Unicode characters. +-- +-- For example, UTF-8 is an encoding of Unicode characters into a sequence +-- of bytes. The 'TextEncoding' for UTF-8 is 'utf8'. +data TextEncoding + = forall dstate estate . TextEncoding { + mkTextDecoder :: IO (TextDecoder dstate), + mkTextEncoder :: IO (TextEncoder estate) + } diff --git a/lib/base/src/GHC/IO/Encoding/UTF16.hs b/lib/base/src/GHC/IO/Encoding/UTF16.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/UTF16.hs @@ -0,0 +1,342 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.UTF16 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-16 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.UTF16 ( + utf16, + utf16_decode, + utf16_encode, + + utf16be, + utf16be_decode, + utf16be_encode, + + utf16le, + utf16le_decode, + utf16le_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +-- import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +import Data.Bits +import Data.Maybe +import GHC.IORef + +#if DEBUG +import System.Posix.Internals +import Foreign.C +import GHC.Show + +puts :: String -> IO () +puts s = do withCStringLen (s++"\n") $ \(p,len) -> + c_write 1 p (fromIntegral len) + return () +#endif + +-- ----------------------------------------------------------------------------- +-- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM + +utf16 :: TextEncoding +utf16 = TextEncoding { mkTextDecoder = utf16_DF, + mkTextEncoder = utf16_EF } + +utf16_DF :: IO (TextDecoder (Maybe DecodeBuffer)) +utf16_DF = do + seen_bom <- newIORef Nothing + return (BufferCodec { + encode = utf16_decode seen_bom, + close = return (), + getState = readIORef seen_bom, + setState = writeIORef seen_bom + }) + +utf16_EF :: IO (TextEncoder Bool) +utf16_EF = do + done_bom <- newIORef False + return (BufferCodec { + encode = utf16_encode done_bom, + close = return (), + getState = readIORef done_bom, + setState = writeIORef done_bom + }) + +utf16_encode :: IORef Bool -> EncodeBuffer +utf16_encode done_bom input + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + = do + b <- readIORef done_bom + if b then utf16_native_encode input output + else if os - ow < 2 + then return (input,output) + else do + writeIORef done_bom True + writeWord8Buf oraw ow bom1 + writeWord8Buf oraw (ow+1) bom2 + utf16_native_encode input output{ bufR = ow+2 } + +utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf16_decode seen_bom + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } + output + = do + mb <- readIORef seen_bom + case mb of + Just decode -> decode input output + Nothing -> + if iw - ir < 2 then return (input,output) else do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + case () of + _ | c0 == bomB && c1 == bomL -> do + writeIORef seen_bom (Just utf16be_decode) + utf16be_decode input{ bufL= ir+2 } output + | c0 == bomL && c1 == bomB -> do + writeIORef seen_bom (Just utf16le_decode) + utf16le_decode input{ bufL= ir+2 } output + | otherwise -> do + writeIORef seen_bom (Just utf16_native_decode) + utf16_native_decode input output + + +bomB, bomL, bom1, bom2 :: Word8 +bomB = 0xfe +bomL = 0xff + +-- choose UTF-16BE by default for UTF-16 output +utf16_native_decode :: DecodeBuffer +utf16_native_decode = utf16be_decode + +utf16_native_encode :: EncodeBuffer +utf16_native_encode = utf16be_encode + +bom1 = bomB +bom2 = bomL + +-- ----------------------------------------------------------------------------- +-- UTF16LE and UTF16BE + +utf16be :: TextEncoding +utf16be = TextEncoding { mkTextDecoder = utf16be_DF, + mkTextEncoder = utf16be_EF } + +utf16be_DF :: IO (TextDecoder ()) +utf16be_DF = + return (BufferCodec { + encode = utf16be_decode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf16be_EF :: IO (TextEncoder ()) +utf16be_EF = + return (BufferCodec { + encode = utf16be_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf16le :: TextEncoding +utf16le = TextEncoding { mkTextDecoder = utf16le_DF, + mkTextEncoder = utf16le_EF } + +utf16le_DF :: IO (TextDecoder ()) +utf16le_DF = + return (BufferCodec { + encode = utf16le_decode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf16le_EF :: IO (TextEncoder ()) +utf16le_EF = + return (BufferCodec { + encode = utf16le_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + + +utf16be_decode :: DecodeBuffer +utf16be_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | ir + 1 == iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1 + if validate1 x1 + then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) + loop (ir+2) ow' + else if iw - ir < 4 then done ir ow else do + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 + if not (validate2 x1 x2) then invalid else do + ow' <- writeCharBuf oraw ow (chr2 x1 x2) + loop (ir+4) ow' + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +utf16le_decode :: DecodeBuffer +utf16le_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | ir + 1 == iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 + if validate1 x1 + then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) + loop (ir+2) ow' + else if iw - ir < 4 then done ir ow else do + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 + if not (validate2 x1 x2) then invalid else do + ow' <- writeCharBuf oraw ow (chr2 x1 x2) + loop (ir+4) ow' + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "utf16_decode" + "invalid UTF-16 byte sequence" Nothing Nothing) + +utf16be_encode :: EncodeBuffer +utf16be_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 2 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case ord c of + x | x < 0x10000 -> do + writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8)) + writeWord8Buf oraw (ow+1) (fromIntegral x) + loop ir' (ow+2) + | otherwise -> do + if os - ow < 4 then done ir ow else do + let + n1 = x - 0x10000 + c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) + c2 = fromIntegral (n1 `shiftR` 10) + n2 = n1 .&. 0x3FF + c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) + c4 = fromIntegral n2 + -- + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c3 + writeWord8Buf oraw (ow+3) c4 + loop ir' (ow+4) + in + loop ir0 ow0 + +utf16le_encode :: EncodeBuffer +utf16le_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 2 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case ord c of + x | x < 0x10000 -> do + writeWord8Buf oraw ow (fromIntegral x) + writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) + loop ir' (ow+2) + | otherwise -> + if os - ow < 4 then done ir ow else do + let + n1 = x - 0x10000 + c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) + c2 = fromIntegral (n1 `shiftR` 10) + n2 = n1 .&. 0x3FF + c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) + c4 = fromIntegral n2 + -- + writeWord8Buf oraw ow c2 + writeWord8Buf oraw (ow+1) c1 + writeWord8Buf oraw (ow+2) c4 + writeWord8Buf oraw (ow+3) c3 + loop ir' (ow+4) + in + loop ir0 ow0 + +chr2 :: Word16 -> Word16 -> Char +chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) + where + !x# = word2Int# a# + !y# = word2Int# b# + !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10# + !lower# = y# -# 0xDC00# +{-# INLINE chr2 #-} + +validate1 :: Word16 -> Bool +validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF +{-# INLINE validate1 #-} + +validate2 :: Word16 -> Word16 -> Bool +validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF && + x2 >= 0xDC00 && x2 <= 0xDFFF +{-# INLINE validate2 #-} diff --git a/lib/base/src/GHC/IO/Encoding/UTF32.hs b/lib/base/src/GHC/IO/Encoding/UTF32.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/UTF32.hs @@ -0,0 +1,306 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.UTF32 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-32 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.UTF32 ( + utf32, + utf32_decode, + utf32_encode, + + utf32be, + utf32be_decode, + utf32be_encode, + + utf32le, + utf32le_decode, + utf32le_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +-- import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +import Data.Bits +import Data.Maybe +import GHC.IORef + +-- ----------------------------------------------------------------------------- +-- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM + +utf32 :: TextEncoding +utf32 = TextEncoding { mkTextDecoder = utf32_DF, + mkTextEncoder = utf32_EF } + +utf32_DF :: IO (TextDecoder (Maybe DecodeBuffer)) +utf32_DF = do + seen_bom <- newIORef Nothing + return (BufferCodec { + encode = utf32_decode seen_bom, + close = return (), + getState = readIORef seen_bom, + setState = writeIORef seen_bom + }) + +utf32_EF :: IO (TextEncoder Bool) +utf32_EF = do + done_bom <- newIORef False + return (BufferCodec { + encode = utf32_encode done_bom, + close = return (), + getState = readIORef done_bom, + setState = writeIORef done_bom + }) + +utf32_encode :: IORef Bool -> EncodeBuffer +utf32_encode done_bom input + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + = do + b <- readIORef done_bom + if b then utf32_native_encode input output + else if os - ow < 4 + then return (input,output) + else do + writeIORef done_bom True + writeWord8Buf oraw ow bom0 + writeWord8Buf oraw (ow+1) bom1 + writeWord8Buf oraw (ow+2) bom2 + writeWord8Buf oraw (ow+3) bom3 + utf32_native_encode input output{ bufR = ow+4 } + +utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf32_decode seen_bom + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } + output + = do + mb <- readIORef seen_bom + case mb of + Just decode -> decode input output + Nothing -> + if iw - ir < 4 then return (input,output) else do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + case () of + _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do + writeIORef seen_bom (Just utf32be_decode) + utf32be_decode input{ bufL= ir+4 } output + _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do + writeIORef seen_bom (Just utf32le_decode) + utf32le_decode input{ bufL= ir+4 } output + | otherwise -> do + writeIORef seen_bom (Just utf32_native_decode) + utf32_native_decode input output + + +bom0, bom1, bom2, bom3 :: Word8 +bom0 = 0 +bom1 = 0 +bom2 = 0xfe +bom3 = 0xff + +-- choose UTF-32BE by default for UTF-32 output +utf32_native_decode :: DecodeBuffer +utf32_native_decode = utf32be_decode + +utf32_native_encode :: EncodeBuffer +utf32_native_encode = utf32be_encode + +-- ----------------------------------------------------------------------------- +-- UTF32LE and UTF32BE + +utf32be :: TextEncoding +utf32be = TextEncoding { mkTextDecoder = utf32be_DF, + mkTextEncoder = utf32be_EF } + +utf32be_DF :: IO (TextDecoder ()) +utf32be_DF = + return (BufferCodec { + encode = utf32be_decode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf32be_EF :: IO (TextEncoder ()) +utf32be_EF = + return (BufferCodec { + encode = utf32be_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + + +utf32le :: TextEncoding +utf32le = TextEncoding { mkTextDecoder = utf32le_DF, + mkTextEncoder = utf32le_EF } + +utf32le_DF :: IO (TextDecoder ()) +utf32le_DF = + return (BufferCodec { + encode = utf32le_decode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf32le_EF :: IO (TextEncoder ()) +utf32le_EF = + return (BufferCodec { + encode = utf32le_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + + +utf32be_decode :: DecodeBuffer +utf32be_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || iw - ir < 4 = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x1 = chr4 c0 c1 c2 c3 + if not (validate x1) then invalid else do + ow' <- writeCharBuf oraw ow x1 + loop (ir+4) ow' + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +utf32le_decode :: DecodeBuffer +utf32le_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || iw - ir < 4 = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x1 = chr4 c3 c2 c1 c0 + if not (validate x1) then invalid else do + ow' <- writeCharBuf oraw ow x1 + loop (ir+4) ow' + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "utf32_decode" + "invalid UTF-32 byte sequence" Nothing Nothing) + +utf32be_encode :: EncodeBuffer +utf32be_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 4 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + let (c0,c1,c2,c3) = ord4 c + writeWord8Buf oraw ow c0 + writeWord8Buf oraw (ow+1) c1 + writeWord8Buf oraw (ow+2) c2 + writeWord8Buf oraw (ow+3) c3 + loop ir' (ow+4) + in + loop ir0 ow0 + +utf32le_encode :: EncodeBuffer +utf32le_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 4 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + let (c0,c1,c2,c3) = ord4 c + writeWord8Buf oraw ow c3 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c1 + writeWord8Buf oraw (ow+3) c0 + loop ir' (ow+4) + in + loop ir0 ow0 + +chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char +chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = + C# (chr# (z1# +# z2# +# z3# +# z4#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !y3# = word2Int# x3# + !y4# = word2Int# x4# + !z1# = uncheckedIShiftL# y1# 24# + !z2# = uncheckedIShiftL# y2# 16# + !z3# = uncheckedIShiftL# y3# 8# + !z4# = y4# +{-# INLINE chr4 #-} + +ord4 :: Char -> (Word8,Word8,Word8,Word8) +ord4 c = (fromIntegral (x `shiftR` 24), + fromIntegral (x `shiftR` 16), + fromIntegral (x `shiftR` 8), + fromIntegral x) + where + x = ord c +{-# INLINE ord4 #-} + + +validate :: Char -> Bool +validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF) + where x1 = ord c +{-# INLINE validate #-} diff --git a/lib/base/src/GHC/IO/Encoding/UTF8.hs b/lib/base/src/GHC/IO/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Encoding/UTF8.hs @@ -0,0 +1,342 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.UTF8 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-8 Codec for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.UTF8 ( + utf8, + utf8_bom, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.IORef +-- import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +import Data.Bits +import Data.Maybe + +utf8 :: TextEncoding +utf8 = TextEncoding { mkTextDecoder = utf8_DF, + mkTextEncoder = utf8_EF } + +utf8_DF :: IO (TextDecoder ()) +utf8_DF = + return (BufferCodec { + encode = utf8_decode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf8_EF :: IO (TextEncoder ()) +utf8_EF = + return (BufferCodec { + encode = utf8_encode, + close = return (), + getState = return (), + setState = const $ return () + }) + +utf8_bom :: TextEncoding +utf8_bom = TextEncoding { mkTextDecoder = utf8_bom_DF, + mkTextEncoder = utf8_bom_EF } + +utf8_bom_DF :: IO (TextDecoder Bool) +utf8_bom_DF = do + ref <- newIORef True + return (BufferCodec { + encode = utf8_bom_decode ref, + close = return (), + getState = readIORef ref, + setState = writeIORef ref + }) + +utf8_bom_EF :: IO (TextEncoder Bool) +utf8_bom_EF = do + ref <- newIORef True + return (BufferCodec { + encode = utf8_bom_encode ref, + close = return (), + getState = readIORef ref, + setState = writeIORef ref + }) + +utf8_bom_decode :: IORef Bool -> DecodeBuffer +utf8_bom_decode ref + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } + output + = do + first <- readIORef ref + if not first + then utf8_decode input output + else do + let no_bom = do writeIORef ref False; utf8_decode input output + if iw - ir < 1 then return (input,output) else do + c0 <- readWord8Buf iraw ir + if (c0 /= bom0) then no_bom else do + if iw - ir < 2 then return (input,output) else do + c1 <- readWord8Buf iraw (ir+1) + if (c1 /= bom1) then no_bom else do + if iw - ir < 3 then return (input,output) else do + c2 <- readWord8Buf iraw (ir+2) + if (c2 /= bom2) then no_bom else do + -- found a BOM, ignore it and carry on + writeIORef ref False + utf8_decode input{ bufL = ir + 3 } output + +utf8_bom_encode :: IORef Bool -> EncodeBuffer +utf8_bom_encode ref input + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + = do + b <- readIORef ref + if not b then utf8_encode input output + else if os - ow < 3 + then return (input,output) + else do + writeIORef ref False + writeWord8Buf oraw ow bom0 + writeWord8Buf oraw (ow+1) bom1 + writeWord8Buf oraw (ow+2) bom2 + utf8_encode input output{ bufR = ow+3 } + +bom0, bom1, bom2 :: Word8 +bom0 = 0xef +bom1 = 0xbb +bom2 = 0xbf + +utf8_decode :: DecodeBuffer +utf8_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + case c0 of + _ | c0 <= 0x7f -> do + ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) + loop (ir+1) ow' + | c0 >= 0xc0 && c0 <= 0xdf -> + if iw - ir < 2 then done ir ow else do + c1 <- readWord8Buf iraw (ir+1) + if (c1 < 0x80 || c1 >= 0xc0) then invalid else do + ow' <- writeCharBuf oraw ow (chr2 c0 c1) + loop (ir+2) ow' + | c0 >= 0xe0 && c0 <= 0xef -> + case iw - ir of + 1 -> done ir ow + 2 -> do -- check for an error even when we don't have + -- the full sequence yet (#3341) + c1 <- readWord8Buf iraw (ir+1) + if not (validate3 c0 c1 0x80) + then invalid else done ir ow + _ -> do + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + if not (validate3 c0 c1 c2) then invalid else do + ow' <- writeCharBuf oraw ow (chr3 c0 c1 c2) + loop (ir+3) ow' + | c0 >= 0xf0 -> + case iw - ir of + 1 -> done ir ow + 2 -> do -- check for an error even when we don't have + -- the full sequence yet (#3341) + c1 <- readWord8Buf iraw (ir+1) + if not (validate4 c0 c1 0x80 0x80) + then invalid else done ir ow + 3 -> do + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + if not (validate4 c0 c1 c2 0x80) + then invalid else done ir ow + _ -> do + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + if not (validate4 c0 c1 c2 c3) then invalid else do + ow' <- writeCharBuf oraw ow (chr4 c0 c1 c2 c3) + loop (ir+4) ow' + | otherwise -> + invalid + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "utf8_decode" + "invalid UTF-8 byte sequence" Nothing Nothing) + +utf8_encode :: EncodeBuffer +utf8_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case ord c of + x | x <= 0x7F -> do + writeWord8Buf oraw ow (fromIntegral x) + loop ir' (ow+1) + | x <= 0x07FF -> + if os - ow < 2 then done ir ow else do + let (c1,c2) = ord2 c + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + loop ir' (ow+2) + | x <= 0xFFFF -> do + if os - ow < 3 then done ir ow else do + let (c1,c2,c3) = ord3 c + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c3 + loop ir' (ow+3) + | otherwise -> do + if os - ow < 4 then done ir ow else do + let (c1,c2,c3,c4) = ord4 c + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c3 + writeWord8Buf oraw (ow+3) c4 + loop ir' (ow+4) + in + loop ir0 ow0 + +-- ----------------------------------------------------------------------------- +-- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8 + +ord2 :: Char -> (Word8,Word8) +ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8,Word8,Word8) +ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord4 :: Char -> (Word8,Word8,Word8,Word8) +ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (n .&. 0x3F) + 0x80 + +chr2 :: Word8 -> Word8 -> Char +chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# + !z2# = y2# -# 0x80# +{-# INLINE chr2 #-} + +chr3 :: Word8 -> Word8 -> Word8 -> Char +chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !y3# = word2Int# x3# + !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# + !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# + !z3# = y3# -# 0x80# +{-# INLINE chr3 #-} + +chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char +chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = + C# (chr# (z1# +# z2# +# z3# +# z4#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !y3# = word2Int# x3# + !y4# = word2Int# x4# + !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# + !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# + !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6# + !z4# = y4# -# 0x80# +{-# INLINE chr4 #-} + +between :: Word8 -- ^ byte to check + -> Word8 -- ^ lower bound + -> Word8 -- ^ upper bound + -> Bool +between x y z = x >= y && x <= z +{-# INLINE between #-} + +validate3 :: Word8 -> Word8 -> Word8 -> Bool +{-# INLINE validate3 #-} +validate3 x1 x2 x3 = validate3_1 || + validate3_2 || + validate3_3 || + validate3_4 + where + validate3_1 = (x1 == 0xE0) && + between x2 0xA0 0xBF && + between x3 0x80 0xBF + validate3_2 = between x1 0xE1 0xEC && + between x2 0x80 0xBF && + between x3 0x80 0xBF + validate3_3 = x1 == 0xED && + between x2 0x80 0x9F && + between x3 0x80 0xBF + validate3_4 = between x1 0xEE 0xEF && + between x2 0x80 0xBF && + between x3 0x80 0xBF + +validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool +{-# INLINE validate4 #-} +validate4 x1 x2 x3 x4 = validate4_1 || + validate4_2 || + validate4_3 + where + validate4_1 = x1 == 0xF0 && + between x2 0x90 0xBF && + between x3 0x80 0xBF && + between x4 0x80 0xBF + validate4_2 = between x1 0xF1 0xF3 && + between x2 0x80 0xBF && + between x3 0x80 0xBF && + between x4 0x80 0xBF + validate4_3 = x1 == 0xF4 && + between x2 0x80 0x8F && + between x3 0x80 0xBF && + between x4 0x80 0xBF diff --git a/lib/base/src/GHC/IO/Exception.hs b/lib/base/src/GHC/IO/Exception.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Exception.hs @@ -0,0 +1,335 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Exception +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- IO-related Exception types and functions +-- +----------------------------------------------------------------------------- + +module GHC.IO.Exception ( + BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar, + BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM, + Deadlock(..), + AssertionFailed(..), + AsyncException(..), stackOverflow, heapOverflow, + ArrayException(..), + ExitCode(..), + + ioException, + ioError, + IOError, + IOException(..), + IOErrorType(..), + userError, + assertError, + unsupportedOperation, + untangle, + ) where + +import GHC.Base +import GHC.List +import GHC.IO +import GHC.Show +import GHC.Read +import GHC.Exception +import Data.Maybe +import GHC.IO.Handle.Types +import Foreign.C.Types + +import Data.Typeable ( Typeable ) + +-- ------------------------------------------------------------------------ +-- Exception datatypes and operations + +-- |The thread is blocked on an @MVar@, but there are no other references +-- to the @MVar@ so it can't ever continue. +data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar + deriving Typeable + +instance Exception BlockedIndefinitelyOnMVar + +instance Show BlockedIndefinitelyOnMVar where + showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely in an MVar operation" + +blockedIndefinitelyOnMVar :: SomeException -- for the RTS +blockedIndefinitelyOnMVar = toException BlockedIndefinitelyOnMVar + +----- + +-- |The thread is waiting to retry an STM transaction, but there are no +-- other references to any @TVar@s involved, so it can't ever continue. +data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM + deriving Typeable + +instance Exception BlockedIndefinitelyOnSTM + +instance Show BlockedIndefinitelyOnSTM where + showsPrec _ BlockedIndefinitelyOnSTM = showString "thread blocked indefinitely in an STM transaction" + +blockedIndefinitelyOnSTM :: SomeException -- for the RTS +blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM + +----- + +-- |There are no runnable threads, so the program is deadlocked. +-- The @Deadlock@ exception is raised in the main thread only. +data Deadlock = Deadlock + deriving Typeable + +instance Exception Deadlock + +instance Show Deadlock where + showsPrec _ Deadlock = showString "<>" + +----- + +-- |'assert' was applied to 'False'. +data AssertionFailed = AssertionFailed String + deriving Typeable + +instance Exception AssertionFailed + +instance Show AssertionFailed where + showsPrec _ (AssertionFailed err) = showString err + +----- + +-- |Asynchronous exceptions. +data AsyncException + = StackOverflow + -- ^The current thread\'s stack exceeded its limit. + -- Since an exception has been raised, the thread\'s stack + -- will certainly be below its limit again, but the + -- programmer should take remedial action + -- immediately. + | HeapOverflow + -- ^The program\'s heap is reaching its limit, and + -- the program should take action to reduce the amount of + -- live data it has. Notes: + -- + -- * It is undefined which thread receives this exception. + -- + -- * GHC currently does not throw 'HeapOverflow' exceptions. + | ThreadKilled + -- ^This exception is raised by another thread + -- calling 'Control.Concurrent.killThread', or by the system + -- if it needs to terminate the thread for some + -- reason. + | UserInterrupt + -- ^This exception is raised by default in the main thread of + -- the program when the user requests to terminate the program + -- via the usual mechanism(s) (e.g. Control-C in the console). + deriving (Eq, Ord, Typeable) + +instance Exception AsyncException + +-- | Exceptions generated by array operations +data ArrayException + = IndexOutOfBounds String + -- ^An attempt was made to index an array outside + -- its declared bounds. + | UndefinedElement String + -- ^An attempt was made to evaluate an element of an + -- array that had not been initialized. + deriving (Eq, Ord, Typeable) + +instance Exception ArrayException + +stackOverflow, heapOverflow :: SomeException -- for the RTS +stackOverflow = toException StackOverflow +heapOverflow = toException HeapOverflow + +instance Show AsyncException where + showsPrec _ StackOverflow = showString "stack overflow" + showsPrec _ HeapOverflow = showString "heap overflow" + showsPrec _ ThreadKilled = showString "thread killed" + showsPrec _ UserInterrupt = showString "user interrupt" + +instance Show ArrayException where + showsPrec _ (IndexOutOfBounds s) + = showString "array index out of range" + . (if not (null s) then showString ": " . showString s + else id) + showsPrec _ (UndefinedElement s) + = showString "undefined array element" + . (if not (null s) then showString ": " . showString s + else id) + +-- ----------------------------------------------------------------------------- +-- The ExitCode type + +-- We need it here because it is used in ExitException in the +-- Exception datatype (above). + +data ExitCode + = ExitSuccess -- ^ indicates successful termination; + | ExitFailure Int + -- ^ indicates program failure with an exit code. + -- The exact interpretation of the code is + -- operating-system dependent. In particular, some values + -- may be prohibited (e.g. 0 on a POSIX-compliant system). + deriving (Eq, Ord, Read, Show, Typeable) + +instance Exception ExitCode + +ioException :: IOException -> IO a +ioException err = throwIO err + +-- | Raise an 'IOError' in the 'IO' monad. +ioError :: IOError -> IO a +ioError = ioException + +-- --------------------------------------------------------------------------- +-- IOError type + +-- | The Haskell 98 type for exceptions in the 'IO' monad. +-- Any I\/O operation may raise an 'IOError' instead of returning a result. +-- For a more general type of exception, including also those that arise +-- in pure code, see "Control.Exception.Exception". +-- +-- In Haskell 98, this is an opaque type. +type IOError = IOException + +-- |Exceptions that occur in the @IO@ monad. +-- An @IOException@ records a more specific error type, a descriptive +-- string and maybe the handle that was used when the error was +-- flagged. +data IOException + = IOError { + ioe_handle :: Maybe Handle, -- the handle used by the action flagging + -- the error. + ioe_type :: IOErrorType, -- what it was. + ioe_location :: String, -- location. + ioe_description :: String, -- error type specific information. + ioe_errno :: Maybe CInt, -- errno leading to this error, if any. + ioe_filename :: Maybe FilePath -- filename the error is related to. + } + deriving Typeable + +instance Exception IOException + +instance Eq IOException where + (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) = + e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2 + +-- | An abstract type that contains a value for each variant of 'IOError'. +data IOErrorType + -- Haskell 98: + = AlreadyExists + | NoSuchThing + | ResourceBusy + | ResourceExhausted + | EOF + | IllegalOperation + | PermissionDenied + | UserError + -- GHC only: + | UnsatisfiedConstraints + | SystemError + | ProtocolError + | OtherError + | InvalidArgument + | InappropriateType + | HardwareFault + | UnsupportedOperation + | TimeExpired + | ResourceVanished + | Interrupted + +instance Eq IOErrorType where + x == y = getTag x ==# getTag y + +instance Show IOErrorType where + showsPrec _ e = + showString $ + case e of + AlreadyExists -> "already exists" + NoSuchThing -> "does not exist" + ResourceBusy -> "resource busy" + ResourceExhausted -> "resource exhausted" + EOF -> "end of file" + IllegalOperation -> "illegal operation" + PermissionDenied -> "permission denied" + UserError -> "user error" + HardwareFault -> "hardware fault" + InappropriateType -> "inappropriate type" + Interrupted -> "interrupted" + InvalidArgument -> "invalid argument" + OtherError -> "failed" + ProtocolError -> "protocol error" + ResourceVanished -> "resource vanished" + SystemError -> "system error" + TimeExpired -> "timeout" + UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! + UnsupportedOperation -> "unsupported operation" + +-- | Construct an 'IOError' value with a string describing the error. +-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a +-- 'userError', thus: +-- +-- > instance Monad IO where +-- > ... +-- > fail s = ioError (userError s) +-- +userError :: String -> IOError +userError str = IOError Nothing UserError "" str Nothing Nothing + +-- --------------------------------------------------------------------------- +-- Showing IOErrors + +instance Show IOException where + showsPrec p (IOError hdl iot loc s _ fn) = + (case fn of + Nothing -> case hdl of + Nothing -> id + Just h -> showsPrec p h . showString ": " + Just name -> showString name . showString ": ") . + (case loc of + "" -> id + _ -> showString loc . showString ": ") . + showsPrec p iot . + (case s of + "" -> id + _ -> showString " (" . showString s . showString ")") + +assertError :: Addr# -> Bool -> a -> a +assertError str predicate v + | predicate = v + | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + +unsupportedOperation :: IOError +unsupportedOperation = + (IOError Nothing UnsupportedOperation "" + "Operation is not supported" Nothing Nothing) + +{- +(untangle coded message) expects "coded" to be of the form + "location|details" +It prints + location message details +-} +untangle :: Addr# -> String -> String +untangle coded message + = location + ++ ": " + ++ message + ++ details + ++ "\n" + where + coded_str = unpackCStringUtf8# coded + + (location, details) + = case (span not_bar coded_str) of { (loc, rest) -> + case rest of + ('|':det) -> (loc, ' ' : det) + _ -> (loc, "") + } + not_bar c = c /= '|' diff --git a/lib/base/src/GHC/IO/Exception.hs-boot b/lib/base/src/GHC/IO/Exception.hs-boot new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Exception.hs-boot @@ -0,0 +1,12 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module GHC.IO.Exception where + +import GHC.Base +import GHC.Exception + +data IOException +instance Exception IOException + +type IOError = IOException +userError :: String -> IOError +unsupportedOperation :: IOError diff --git a/lib/base/src/GHC/IO/FD.hs b/lib/base/src/GHC/IO/FD.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/FD.hs @@ -0,0 +1,636 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.FD +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Raw read/write operations on file descriptors +-- +----------------------------------------------------------------------------- + +module GHC.IO.FD ( + FD(..), + openFile, mkFD, release, + setNonBlockingMode, + readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr, + stdin, stdout, stderr + ) where + +import GHC.Base +import GHC.Num +import GHC.Real +import GHC.Show +import GHC.Enum +import Data.Maybe +import Control.Monad +import Data.Typeable + +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Buffer +import GHC.IO.BufferedIO +import qualified GHC.IO.Device +import GHC.IO.Device (SeekMode(..), IODeviceType(..)) +import GHC.Conc +import GHC.IO.Exception + +import Foreign +import Foreign.C +import qualified System.Posix.Internals +import System.Posix.Internals hiding (FD, setEcho, getEcho) +import System.Posix.Types +-- import GHC.Ptr + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False + +-- ----------------------------------------------------------------------------- +-- The file-descriptor IO device + +data FD = FD { + fdFD :: {-# UNPACK #-} !CInt, +#ifdef mingw32_HOST_OS + -- On Windows, a socket file descriptor needs to be read and written + -- using different functions (send/recv). + fdIsSocket_ :: {-# UNPACK #-} !Int +#else + -- On Unix we need to know whether this FD has O_NONBLOCK set. + -- If it has, then we can use more efficient routines to read/write to it. + -- It is always safe for this to be off. + fdIsNonBlocking :: {-# UNPACK #-} !Int +#endif + } + deriving Typeable + +#ifdef mingw32_HOST_OS +fdIsSocket :: FD -> Bool +fdIsSocket fd = fdIsSocket_ fd /= 0 +#endif + +instance Show FD where + show fd = show (fdFD fd) + +instance GHC.IO.Device.RawIO FD where + read = fdRead + readNonBlocking = fdReadNonBlocking + write = fdWrite + writeNonBlocking = fdWriteNonBlocking + +instance GHC.IO.Device.IODevice FD where + ready = ready + close = close + isTerminal = isTerminal + isSeekable = isSeekable + seek = seek + tell = tell + getSize = getSize + setSize = setSize + setEcho = setEcho + getEcho = getEcho + setRaw = setRaw + devType = devType + dup = dup + dup2 = dup2 + +instance BufferedIO FD where + newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state + fillReadBuffer fd buf = readBuf' fd buf + fillReadBuffer0 fd buf = readBufNonBlocking fd buf + flushWriteBuffer fd buf = writeBuf' fd buf + flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf + +readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8) +readBuf' fd buf = do + when c_DEBUG_DUMP $ + puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") + (r,buf') <- readBuf fd buf + when c_DEBUG_DUMP $ + puts ("after: " ++ summaryBuffer buf' ++ "\n") + return (r,buf') + +writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8) +writeBuf' fd buf = do + when c_DEBUG_DUMP $ + puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") + writeBuf fd buf + +-- ----------------------------------------------------------------------------- +-- opening files + +-- | Open a file and make an 'FD' for it. Truncates the file to zero +-- size when the `IOMode` is `WriteMode`. Puts the file descriptor +-- into non-blocking mode on Unix systems. +openFile :: FilePath -> IOMode -> IO (FD,IODeviceType) +openFile filepath iomode = + withFilePath filepath $ \ f -> + + let + oflags1 = case iomode of + ReadMode -> read_flags +#ifdef mingw32_HOST_OS + WriteMode -> write_flags .|. o_TRUNC +#else + WriteMode -> write_flags +#endif + ReadWriteMode -> rw_flags + AppendMode -> append_flags + +#ifdef mingw32_HOST_OS + binary_flags = o_BINARY +#else + binary_flags = 0 +#endif + + oflags = oflags1 .|. binary_flags + in do + + -- the old implementation had a complicated series of three opens, + -- which is perhaps because we have to be careful not to open + -- directories. However, the man pages I've read say that open() + -- always returns EISDIR if the file is a directory and was opened + -- for writing, so I think we're ok with a single open() here... + fd <- throwErrnoIfMinus1Retry "openFile" + (c_open f (fromIntegral oflags) 0o666) + + (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} + False{-not a socket-} + True{-is non-blocking-} + `catchAny` \e -> do _ <- c_close fd + throwIO e + +#ifndef mingw32_HOST_OS + -- we want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. ftruncate() fails on special files + -- like /dev/null. + if iomode == WriteMode && fd_type == RegularFile + then setSize fD 0 + else return () +#endif + + return (fD,fd_type) + +std_flags, output_flags, read_flags, write_flags, rw_flags, + append_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +read_flags = std_flags .|. o_RDONLY +write_flags = output_flags .|. o_WRONLY +rw_flags = output_flags .|. o_RDWR +append_flags = write_flags .|. o_APPEND + + +-- | Make a 'FD' from an existing file descriptor. Fails if the FD +-- refers to a directory. If the FD refers to a file, `mkFD` locks +-- the file according to the Haskell 98 single writer/multiple reader +-- locking semantics (this is why we need the `IOMode` argument too). +mkFD :: CInt + -> IOMode + -> Maybe (IODeviceType, CDev, CIno) + -- the results of fdStat if we already know them, or we want + -- to prevent fdToHandle_stat from doing its own stat. + -- These are used for: + -- - we fail if the FD refers to a directory + -- - if the FD refers to a file, we lock it using (cdev,cino) + -> Bool -- ^ is a socket (on Windows) + -> Bool -- ^ is in non-blocking mode on Unix + -> IO (FD,IODeviceType) + +mkFD fd iomode mb_stat is_socket is_nonblock = do + + let _ = (is_socket, is_nonblock) -- warning suppression + + (fd_type,dev,ino) <- + case mb_stat of + Nothing -> fdStat fd + Just stat -> return stat + + let write = case iomode of + ReadMode -> False + _ -> True + +#ifdef mingw32_HOST_OS + _ <- setmode fd True -- unconditionally set binary mode + let _ = (dev,ino,write) -- warning suppression +#endif + + case fd_type of + Directory -> + ioException (IOError Nothing InappropriateType "openFile" + "is a directory" Nothing Nothing) + +#ifndef mingw32_HOST_OS + -- regular files need to be locked + RegularFile -> do + -- On Windows we use explicit exclusion via sopen() to implement + -- this locking (see __hscore_open()); on Unix we have to + -- implment it in the RTS. + r <- lockFile fd dev ino (fromBool write) + when (r == -1) $ + ioException (IOError Nothing ResourceBusy "openFile" + "file is locked" Nothing Nothing) +#endif + + _other_type -> return () + + return (FD{ fdFD = fd, +#ifndef mingw32_HOST_OS + fdIsNonBlocking = fromEnum is_nonblock +#else + fdIsSocket_ = fromEnum is_socket +#endif + }, + fd_type) + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "__hscore_setmode" + setmode :: CInt -> Bool -> IO CInt +#endif + +-- ----------------------------------------------------------------------------- +-- Standard file descriptors + +stdFD :: CInt -> FD +stdFD fd = FD { fdFD = fd, +#ifdef mingw32_HOST_OS + fdIsSocket_ = 0 +#else + fdIsNonBlocking = 0 + -- We don't set non-blocking mode on standard handles, because it may + -- confuse other applications attached to the same TTY/pipe + -- see Note [nonblock] +#endif + } + +stdin, stdout, stderr :: FD +stdin = stdFD 0 +stdout = stdFD 1 +stderr = stdFD 2 + +-- ----------------------------------------------------------------------------- +-- Operations on file descriptors + +close :: FD -> IO () +close fd = +#ifndef mingw32_HOST_OS + (flip finally) (release fd) $ do +#endif + throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $ +#ifdef mingw32_HOST_OS + if fdIsSocket fd then + c_closesocket (fdFD fd) + else +#endif + c_close (fdFD fd) + +release :: FD -> IO () +#ifdef mingw32_HOST_OS +release _ = return () +#else +release fd = do _ <- unlockFile (fdFD fd) + return () +#endif + +#ifdef mingw32_HOST_OS +foreign import stdcall unsafe "HsBase.h closesocket" + c_closesocket :: CInt -> IO CInt +#endif + +isSeekable :: FD -> IO Bool +isSeekable fd = do + t <- devType fd + return (t == RegularFile || t == RawDevice) + +seek :: FD -> SeekMode -> Integer -> IO () +seek fd mode off = do + throwErrnoIfMinus1Retry_ "seek" $ + c_lseek (fdFD fd) (fromIntegral off) seektype + where + seektype :: CInt + seektype = case mode of + AbsoluteSeek -> sEEK_SET + RelativeSeek -> sEEK_CUR + SeekFromEnd -> sEEK_END + +tell :: FD -> IO Integer +tell fd = + fromIntegral `fmap` + (throwErrnoIfMinus1Retry "hGetPosn" $ + c_lseek (fdFD fd) 0 sEEK_CUR) + +getSize :: FD -> IO Integer +getSize fd = fdFileSize (fdFD fd) + +setSize :: FD -> Integer -> IO () +setSize fd size = do + throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $ + c_ftruncate (fdFD fd) (fromIntegral size) + +devType :: FD -> IO IODeviceType +devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty + +dup :: FD -> IO FD +dup fd = do + newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd) + return fd{ fdFD = newfd } + +dup2 :: FD -> FD -> IO FD +dup2 fd fdto = do + -- Windows' dup2 does not return the new descriptor, unlike Unix + throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $ + c_dup2 (fdFD fd) (fdFD fdto) + return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD + +setNonBlockingMode :: FD -> Bool -> IO FD +setNonBlockingMode fd set = do + setNonBlockingFD (fdFD fd) set +#if defined(mingw32_HOST_OS) + return fd +#else + return fd{ fdIsNonBlocking = fromEnum set } +#endif + +ready :: FD -> Bool -> Int -> IO Bool +ready fd write msecs = do + r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $ + fdReady (fdFD fd) (fromIntegral $ fromEnum $ write) + (fromIntegral msecs) +#if defined(mingw32_HOST_OS) + (fromIntegral $ fromEnum $ fdIsSocket fd) +#else + 0 +#endif + return (toEnum (fromIntegral r)) + +--foreign import ccall safe "fdReady" +-- fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + +fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt +fdReady _ _ _ _ = return 1 + +-- --------------------------------------------------------------------------- +-- Terminal-related stuff + +isTerminal :: FD -> IO Bool +isTerminal fd = c_isatty (fdFD fd) >>= return.toBool + +setEcho :: FD -> Bool -> IO () +setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on + +getEcho :: FD -> IO Bool +getEcho fd = System.Posix.Internals.getEcho (fdFD fd) + +setRaw :: FD -> Bool -> IO () +setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw) + +-- ----------------------------------------------------------------------------- +-- Reading and Writing + +fdRead :: FD -> Ptr Word8 -> Int -> IO Int +fdRead fd ptr bytes = do + r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes) + return (fromIntegral r) + +fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int) +fdReadNonBlocking fd ptr bytes = do + r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr + 0 (fromIntegral bytes) + case r of + (-1) -> return (Nothing) + n -> return (Just (fromIntegral n)) + + +fdWrite :: FD -> Ptr Word8 -> Int -> IO () +fdWrite fd ptr bytes = do + res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes) + let res' = fromIntegral res + if res' < bytes + then fdWrite fd (ptr `plusPtr` res') (bytes - res') + else return () + +-- XXX ToDo: this isn't non-blocking +fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int +fdWriteNonBlocking fd ptr bytes = do + res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0 + (fromIntegral bytes) + return (fromIntegral res) + +-- ----------------------------------------------------------------------------- +-- FD operations + +-- Low level routines for reading/writing to (raw)buffers: + +#ifndef mingw32_HOST_OS + +{- +NOTE [nonblock]: + +Unix has broken semantics when it comes to non-blocking I/O: you can +set the O_NONBLOCK flag on an FD, but it applies to the all other FDs +attached to the same underlying file, pipe or TTY; there's no way to +have private non-blocking behaviour for an FD. See bug #724. + +We fix this by only setting O_NONBLOCK on FDs that we create; FDs that +come from external sources or are exposed externally are left in +blocking mode. This solution has some problems though. We can't +completely simulate a non-blocking read without O_NONBLOCK: several +cases are wrong here. The cases that are wrong: + + * reading/writing to a blocking FD in non-threaded mode. + In threaded mode, we just make a safe call to read(). + In non-threaded mode we call select() before attempting to read, + but that leaves a small race window where the data can be read + from the file descriptor before we issue our blocking read(). + * readRawBufferNoBlock for a blocking FD + +NOTE [2363]: + +In the threaded RTS we could just make safe calls to read()/write() +for file descriptors in blocking mode without worrying about blocking +other threads, but the problem with this is that the thread will be +uninterruptible while it is blocked in the foreign call. See #2363. +So now we always call fdReady() before reading, and if fdReady +indicates that there's no data, we call threadWaitRead. + +-} + +readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int +readRawBufferPtr loc !fd buf off len + | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block + | otherwise = do r <- throwErrnoIfMinus1 loc + (unsafe_fdReady (fdFD fd) 0 0 0) + if r /= 0 + then read + else do threadWaitRead (fromIntegral (fdFD fd)); read + where + do_read call = fromIntegral `fmap` + throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitRead (fromIntegral (fdFD fd))) + read = if threaded then safe_read else unsafe_read + unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len) + safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) + +-- return: -1 indicates EOF, >=0 is bytes read +readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int +readRawBufferPtrNoBlock loc !fd buf off len + | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block + | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0 + if r /= 0 then safe_read + else return 0 + -- XXX see note [nonblock] + where + do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1)) + case r of + (-1) -> return 0 + 0 -> return (-1) + n -> return (fromIntegral n) + unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len) + safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) + +writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +writeRawBufferPtr loc !fd buf off len + | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block + | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 + if r /= 0 + then write + else do threadWaitWrite (fromIntegral (fdFD fd)); write + where + do_write call = fromIntegral `fmap` + throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitWrite (fromIntegral (fdFD fd))) + write = if threaded then safe_write else unsafe_write + unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len) + safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) + +writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +writeRawBufferPtrNoBlock loc !fd buf off len + | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block + | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 + if r /= 0 then write + else return 0 + where + do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1)) + case r of + (-1) -> return 0 + n -> return (fromIntegral n) + write = if threaded then safe_write else unsafe_write + unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len) + safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) + +isNonBlocking :: FD -> Bool +isNonBlocking fd = fdIsNonBlocking fd /= 0 + +--foreign import ccall unsafe "fdReady" +-- unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + +unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt +unsafe_fdReady _ _ _ _ = return 1 + +#else /* mingw32_HOST_OS.... */ + +readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +readRawBufferPtr loc !fd buf off len + | threaded = blockingReadRawBufferPtr loc fd buf off len + | otherwise = asyncReadRawBufferPtr loc fd buf off len + +writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +writeRawBufferPtr loc !fd buf off len + | threaded = blockingWriteRawBufferPtr loc fd buf off len + | otherwise = asyncWriteRawBufferPtr loc fd buf off len + +readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +readRawBufferPtrNoBlock = readRawBufferPtr + +writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +writeRawBufferPtrNoBlock = writeRawBufferPtr + +-- Async versions of the read/write primitives, for the non-threaded RTS + +asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +asyncReadRawBufferPtr loc !fd buf off len = do + (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) + (fromIntegral len) (buf `plusPtr` off) + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +asyncWriteRawBufferPtr loc !fd buf off len = do + (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) + (fromIntegral len) (buf `plusPtr` off) + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +-- Blocking versions of the read/write primitives, for the threaded RTS + +blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt +blockingReadRawBufferPtr loc fd buf off len + = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $ + if fdIsSocket fd + then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0 + else c_safe_read (fdFD fd) (buf `plusPtr` off) len + +blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt +blockingWriteRawBufferPtr loc fd buf off len + = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $ + if fdIsSocket fd + then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0 + else c_safe_write (fdFD fd) (buf `plusPtr` off) len + +-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. +-- These calls may block, but that's ok. + +foreign import stdcall safe "recv" + c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize + +foreign import stdcall safe "send" + c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize + +#endif + +--foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool +threaded :: Bool +threaded = False + +-- ----------------------------------------------------------------------------- +-- utils + +#ifndef mingw32_HOST_OS +throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize +throwErrnoIfMinus1RetryOnBlock loc f on_block = + do + res <- f + if (res :: CSsize) == -1 + then do + err <- getErrno + if err == eINTR + then throwErrnoIfMinus1RetryOnBlock loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do on_block + else throwErrno loc + else return res +#endif + +-- ----------------------------------------------------------------------------- +-- Locking/unlocking + +#ifndef mingw32_HOST_OS +foreign import ccall unsafe "lockFile" + lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt + +foreign import ccall unsafe "unlockFile" + unlockFile :: CInt -> IO CInt +#endif + +puts :: String -> IO () +puts s = do _ <- withCStringLen s $ \(p,len) -> + c_write 1 (castPtr p) (fromIntegral len) + return () diff --git a/lib/base/src/GHC/IO/Handle.hs b/lib/base/src/GHC/IO/Handle.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle.hs @@ -0,0 +1,743 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -XRecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle +-- Copyright : (c) The University of Glasgow, 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable +-- +-- External API for GHC's Handle implementation +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle ( + Handle, + BufferMode(..), + + mkFileHandle, mkDuplexHandle, + + hFileSize, hSetFileSize, hIsEOF, hLookAhead, + hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding, + hFlush, hFlushAll, hDuplicate, hDuplicateTo, + + hClose, hClose_help, + + HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, + SeekMode(..), hSeek, hTell, + + hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, + hSetEcho, hGetEcho, hIsTerminalDevice, + + hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline, + noNewlineTranslation, universalNewlineMode, nativeNewlineMode, + + hShow, + + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + + hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking + ) where + +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Encoding +import GHC.IO.Buffer +import GHC.IO.BufferedIO ( BufferedIO ) +import GHC.IO.Device as IODevice +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import GHC.IO.Handle.Text +import qualified GHC.IO.BufferedIO as Buffered + +import GHC.Base +import GHC.Exception +import GHC.MVar +import GHC.IORef +import GHC.Show +import GHC.Num +import GHC.Real +import Data.Maybe +import Data.Typeable +import Control.Monad + +-- --------------------------------------------------------------------------- +-- Closing a handle + +-- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the +-- computation finishes, if @hdl@ is writable its buffer is flushed as +-- for 'hFlush'. +-- Performing 'hClose' on a handle that has already been closed has no effect; +-- doing so is not an error. All other operations on a closed handle will fail. +-- If 'hClose' fails for any reason, any further operations (apart from +-- 'hClose') on the handle will still fail as if @hdl@ had been successfully +-- closed. + +hClose :: Handle -> IO () +hClose h@(FileHandle _ m) = do + mb_exc <- hClose' h m + hClose_maybethrow mb_exc h +hClose h@(DuplexHandle _ r w) = do + mb_exc1 <- hClose' h w + mb_exc2 <- hClose' h r + case mb_exc1 of + Nothing -> return () + Just e -> hClose_maybethrow mb_exc2 h + +hClose_maybethrow :: Maybe SomeException -> Handle -> IO () +hClose_maybethrow Nothing h = return () +hClose_maybethrow (Just e) h = hClose_rethrow e h + +hClose_rethrow :: SomeException -> Handle -> IO () +hClose_rethrow e h = + case fromException e of + Just ioe -> ioError (augmentIOError ioe "hClose" h) + Nothing -> throwIO e + +hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) +hClose' h m = withHandle' "hClose" h m $ hClose_help + +----------------------------------------------------------------------------- +-- Detecting and changing the size of a file + +-- | For a handle @hdl@ which attached to a physical file, +-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes. + +hFileSize :: Handle -> IO Integer +hFileSize handle = + withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + _ -> do flushWriteBuffer handle_ + r <- IODevice.getSize dev + if r /= -1 + then return r + else ioException (IOError Nothing InappropriateType "hFileSize" + "not a regular file" Nothing Nothing) + + +-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. + +hSetFileSize :: Handle -> Integer -> IO () +hSetFileSize handle size = + withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + _ -> do flushWriteBuffer handle_ + IODevice.setSize dev size + return () + +-- --------------------------------------------------------------------------- +-- Detecting the End of Input + +-- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns +-- 'True' if no further input can be taken from @hdl@ or for a +-- physical file, if the current I\/O position is equal to the length of +-- the file. Otherwise, it returns 'False'. +-- +-- NOTE: 'hIsEOF' may block, because it has to attempt to read from +-- the stream to determine whether there is any more data to be read. + +hIsEOF :: Handle -> IO Bool +hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do + + cbuf <- readIORef haCharBuffer + if not (isEmptyBuffer cbuf) then return False else do + + bbuf <- readIORef haByteBuffer + if not (isEmptyBuffer bbuf) then return False else do + + -- NB. do no decoding, just fill the byte buffer; see #3808 + (r,bbuf') <- Buffered.fillReadBuffer haDevice bbuf + if r == 0 + then return True + else do writeIORef haByteBuffer bbuf' + return False + +-- --------------------------------------------------------------------------- +-- Looking ahead + +-- | Computation 'hLookAhead' returns the next character from the handle +-- without removing it from the input buffer, blocking until a character +-- is available. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hLookAhead :: Handle -> IO Char +hLookAhead handle = + wantReadableHandle_ "hLookAhead" handle hLookAhead_ + +-- --------------------------------------------------------------------------- +-- Buffering Operations + +-- Three kinds of buffering are supported: line-buffering, +-- block-buffering or no-buffering. See GHC.IO.Handle for definition and +-- further explanation of what the type represent. + +-- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for +-- handle @hdl@ on subsequent reads and writes. +-- +-- If the buffer mode is changed from 'BlockBuffering' or +-- 'LineBuffering' to 'NoBuffering', then +-- +-- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; +-- +-- * if @hdl@ is not writable, the contents of the buffer is discarded. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if the handle has already been used for reading +-- or writing and the implementation does not allow the buffering mode +-- to be changed. + +hSetBuffering :: Handle -> BufferMode -> IO () +hSetBuffering handle mode = + withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> do + if mode == haBufferMode then return handle_ else do + + {- Note: + - we flush the old buffer regardless of whether + the new buffer could fit the contents of the old buffer + or not. + - allow a handle's buffering to change even if IO has + occurred (ANSI C spec. does not allow this, nor did + the previous implementation of IO.hSetBuffering). + - a non-standard extension is to allow the buffering + of semi-closed handles to change [sof 6/98] + -} + flushCharBuffer handle_ + + let state = initBufferState haType + reading = not (isWritableHandleType haType) + + new_buf <- + case mode of + -- See [note Buffer Sizing], GHC.IO.Handle.Types + NoBuffering | reading -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + | otherwise -> newCharBuffer 1 state + LineBuffering -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + BlockBuffering Nothing -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n + | otherwise -> newCharBuffer n state + + writeIORef haCharBuffer new_buf + + -- for input terminals we need to put the terminal into + -- cooked or raw mode depending on the type of buffering. + is_tty <- IODevice.isTerminal haDevice + when (is_tty && isReadableHandleType haType) $ + case mode of +#ifndef mingw32_HOST_OS + -- 'raw' mode under win32 is a bit too specialised (and troublesome + -- for most common uses), so simply disable its use here. + NoBuffering -> IODevice.setRaw haDevice True +#else + NoBuffering -> return () +#endif + _ -> IODevice.setRaw haDevice False + + -- throw away spare buffers, they might be the wrong size + writeIORef haBuffers BufferListNil + + return Handle__{ haBufferMode = mode,.. } + +-- ----------------------------------------------------------------------------- +-- hSetEncoding + +-- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding +-- for the handle @hdl@ to @encoding@. The default encoding when a 'Handle' is +-- created is 'localeEncoding', namely the default encoding for the current +-- locale. +-- +-- To create a 'Handle' with no encoding at all, use 'openBinaryFile'. To +-- stop further encoding or decoding on an existing 'Handle', use +-- 'hSetBinaryMode'. +-- +-- 'hSetEncoding' may need to flush buffered data in order to change +-- the encoding. +-- +hSetEncoding :: Handle -> TextEncoding -> IO () +hSetEncoding hdl encoding = do + withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do + flushCharBuffer h_ + openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do + bbuf <- readIORef haByteBuffer + ref <- newIORef (error "last_decode") + return (Handle__{ haLastDecode = ref, + haDecoder = mb_decoder, + haEncoder = mb_encoder, + haCodec = Just encoding, .. }) + +-- | Return the current 'TextEncoding' for the specified 'Handle', or +-- 'Nothing' if the 'Handle' is in binary mode. +-- +-- Note that the 'TextEncoding' remembers nothing about the state of +-- the encoder/decoder in use on this 'Handle'. For example, if the +-- encoding in use is UTF-16, then using 'hGetEncoding' and +-- 'hSetEncoding' to save and restore the encoding may result in an +-- extra byte-order-mark being written to the file. +-- +hGetEncoding :: Handle -> IO (Maybe TextEncoding) +hGetEncoding hdl = + withHandle_ "hGetEncoding" hdl $ \h_@Handle__{..} -> return haCodec + +-- ----------------------------------------------------------------------------- +-- hFlush + +-- | The action 'hFlush' @hdl@ causes any items buffered for output +-- in handle @hdl@ to be sent immediately to the operating system. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. +-- It is unspecified whether the characters in the buffer are discarded +-- or retained under these circumstances. + +hFlush :: Handle -> IO () +hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer + +-- | The action 'hFlushAll' @hdl@ flushes all buffered data in @hdl@, +-- including any buffered read data. Buffered read data is flushed +-- by seeking the file position back to the point before the bufferred +-- data was read, and hence only works if @hdl@ is seekable (see +-- 'hIsSeekable'). +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. +-- It is unspecified whether the characters in the buffer are discarded +-- or retained under these circumstances; +-- +-- * 'isIllegalOperation' if @hdl@ has buffered read data, and is not +-- seekable. + +hFlushAll :: Handle -> IO () +hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer + +-- ----------------------------------------------------------------------------- +-- Repositioning Handles + +data HandlePosn = HandlePosn Handle HandlePosition + +instance Eq HandlePosn where + (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 + +instance Show HandlePosn where + showsPrec p (HandlePosn h pos) = + showsPrec p h . showString " at position " . shows pos + + -- HandlePosition is the Haskell equivalent of POSIX' off_t. + -- We represent it as an Integer on the Haskell side, but + -- cheat slightly in that hGetPosn calls upon a C helper + -- that reports the position back via (merely) an Int. +type HandlePosition = Integer + +-- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of +-- @hdl@ as a value of the abstract type 'HandlePosn'. + +hGetPosn :: Handle -> IO HandlePosn +hGetPosn handle = do + posn <- hTell handle + return (HandlePosn handle posn) + +-- | If a call to 'hGetPosn' @hdl@ returns a position @p@, +-- then computation 'hSetPosn' @p@ sets the position of @hdl@ +-- to the position it held at the time of the call to 'hGetPosn'. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. + +hSetPosn :: HandlePosn -> IO () +hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i + +-- --------------------------------------------------------------------------- +-- hSeek + +{- Note: + - when seeking using `SeekFromEnd', positive offsets (>=0) means + seeking at or past EOF. + + - we possibly deviate from the report on the issue of seeking within + the buffer and whether to flush it or not. The report isn't exactly + clear here. +-} + +-- | Computation 'hSeek' @hdl mode i@ sets the position of handle +-- @hdl@ depending on @mode@. +-- The offset @i@ is given in terms of 8-bit bytes. +-- +-- If @hdl@ is block- or line-buffered, then seeking to a position which is not +-- in the current buffer will first cause any items in the output buffer to be +-- written to the device, and then cause the input buffer to be discarded. +-- Some handles may not be seekable (see 'hIsSeekable'), or only support a +-- subset of the possible positioning operations (for instance, it may only +-- be possible to seek to the end of a tape, or to a positive offset from +-- the beginning or current position). +-- It is not possible to set a negative I\/O position, or for +-- a physical file, an I\/O position beyond the current end-of-file. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. + +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek handle mode offset = + wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do + debugIO ("hSeek " ++ show (mode,offset)) + buf <- readIORef haCharBuffer + + if isWriteBuffer buf + then do flushWriteBuffer handle_ + IODevice.seek haDevice mode offset + else do + + let r = bufL buf; w = bufR buf + if mode == RelativeSeek && isNothing haDecoder && + offset >= 0 && offset < fromIntegral (w - r) + then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset } + else do + + flushCharReadBuffer handle_ + flushByteReadBuffer handle_ + IODevice.seek haDevice mode offset + + +hTell :: Handle -> IO Integer +hTell handle = + wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do + + posn <- IODevice.tell haDevice + + cbuf <- readIORef haCharBuffer + bbuf <- readIORef haByteBuffer + + let real_posn + | isWriteBuffer cbuf = posn + fromIntegral (bufR cbuf) + | otherwise = posn - fromIntegral (bufR cbuf - bufL cbuf) + - fromIntegral (bufR bbuf - bufL bbuf) + + debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn)) + debugIO (" cbuf: " ++ summaryBuffer cbuf ++ + " bbuf: " ++ summaryBuffer bbuf) + + return real_posn + +-- ----------------------------------------------------------------------------- +-- Handle Properties + +-- A number of operations return information about the properties of a +-- handle. Each of these operations returns `True' if the handle has +-- the specified property, and `False' otherwise. + +hIsOpen :: Handle -> IO Bool +hIsOpen handle = + withHandle_ "hIsOpen" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return False + SemiClosedHandle -> return False + _ -> return True + +hIsClosed :: Handle -> IO Bool +hIsClosed handle = + withHandle_ "hIsClosed" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return True + _ -> return False + +{- not defined, nor exported, but mentioned + here for documentation purposes: + + hSemiClosed :: Handle -> IO Bool + hSemiClosed h = do + ho <- hIsOpen h + hc <- hIsClosed h + return (not (ho || hc)) +-} + +hIsReadable :: Handle -> IO Bool +hIsReadable (DuplexHandle _ _ _) = return True +hIsReadable handle = + withHandle_ "hIsReadable" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + htype -> return (isReadableHandleType htype) + +hIsWritable :: Handle -> IO Bool +hIsWritable (DuplexHandle _ _ _) = return True +hIsWritable handle = + withHandle_ "hIsWritable" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + htype -> return (isWritableHandleType htype) + +-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode +-- for @hdl@. + +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering handle = + withHandle_ "hGetBuffering" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + _ -> + -- We're being non-standard here, and allow the buffering + -- of a semi-closed handle to be queried. -- sof 6/98 + return (haBufferMode handle_) -- could be stricter.. + +hIsSeekable :: Handle -> IO Bool +hIsSeekable handle = + withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> return False + _ -> IODevice.isSeekable haDevice + +-- ----------------------------------------------------------------------------- +-- Changing echo status (Non-standard GHC extensions) + +-- | Set the echoing status of a handle connected to a terminal. + +hSetEcho :: Handle -> Bool -> IO () +hSetEcho handle on = do + isT <- hIsTerminalDevice handle + if not isT + then return () + else + withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> IODevice.setEcho haDevice on + +-- | Get the echoing status of a handle connected to a terminal. + +hGetEcho :: Handle -> IO Bool +hGetEcho handle = do + isT <- hIsTerminalDevice handle + if not isT + then return False + else + withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> IODevice.getEcho haDevice + +-- | Is the handle connected to a terminal? + +hIsTerminalDevice :: Handle -> IO Bool +hIsTerminalDevice handle = do + withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> IODevice.isTerminal haDevice + +-- ----------------------------------------------------------------------------- +-- hSetBinaryMode + +-- | Select binary mode ('True') or text mode ('False') on a open handle. +-- (See also 'openBinaryFile'.) +-- +-- This has the same effect as calling 'hSetEncoding' with 'latin1', together +-- with 'hSetNewlineMode' with 'noNewlineTranslation'. +-- +hSetBinaryMode :: Handle -> Bool -> IO () +hSetBinaryMode handle bin = + withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} -> + do + flushCharBuffer h_ + + let mb_te | bin = Nothing + | otherwise = Just localeEncoding + + openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do + + -- should match the default newline mode, whatever that is + let nl | bin = noNewlineTranslation + | otherwise = nativeNewlineMode + + bbuf <- readIORef haByteBuffer + ref <- newIORef (error "codec_state", bbuf) + + return Handle__{ haLastDecode = ref, + haEncoder = mb_encoder, + haDecoder = mb_decoder, + haCodec = mb_te, + haInputNL = inputNL nl, + haOutputNL = outputNL nl, .. } + +-- ----------------------------------------------------------------------------- +-- hSetNewlineMode + +-- | Set the 'NewlineMode' on the specified 'Handle'. All buffered +-- data is flushed first. +hSetNewlineMode :: Handle -> NewlineMode -> IO () +hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } = + withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} -> + do + flushBuffer h_ + return h_{ haInputNL=i, haOutputNL=o } + +-- ----------------------------------------------------------------------------- +-- Duplicating a Handle + +-- | Returns a duplicate of the original handle, with its own buffer. +-- The two Handles will share a file pointer, however. The original +-- handle's buffer is flushed, including discarding any input data, +-- before the handle is duplicated. + +hDuplicate :: Handle -> IO Handle +hDuplicate h@(FileHandle path m) = do + withHandle_' "hDuplicate" h m $ \h_ -> + dupHandle path h Nothing h_ (Just handleFinalizer) +hDuplicate h@(DuplexHandle path r w) = do + write_side@(FileHandle _ write_m) <- + withHandle_' "hDuplicate" h w $ \h_ -> + dupHandle path h Nothing h_ (Just handleFinalizer) + read_side@(FileHandle _ read_m) <- + withHandle_' "hDuplicate" h r $ \h_ -> + dupHandle path h (Just write_m) h_ Nothing + return (DuplexHandle path read_m write_m) + +dupHandle :: FilePath + -> Handle + -> Maybe (MVar Handle__) + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle +dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do + -- flush the buffer first, so we don't have to copy its contents + flushBuffer h_ + case other_side of + Nothing -> do + new_dev <- IODevice.dup haDevice + dupHandle_ new_dev filepath other_side h_ mb_finalizer + Just r -> + withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do + dupHandle_ dev filepath other_side h_ mb_finalizer + +dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath + -> Maybe (MVar Handle__) + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle +dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do + -- XXX wrong! + let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing + mkHandle new_dev filepath haType True{-buffered-} mb_codec + NewlineMode { inputNL = haInputNL, outputNL = haOutputNL } + mb_finalizer other_side + +-- ----------------------------------------------------------------------------- +-- Replacing a Handle + +{- | +Makes the second handle a duplicate of the first handle. The second +handle will be closed first, if it is not already. + +This can be used to retarget the standard Handles, for example: + +> do h <- openFile "mystdout" WriteMode +> hDuplicateTo h stdout +-} + +hDuplicateTo :: Handle -> Handle -> IO () +hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do + withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do + _ <- hClose_help h2_ + withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do + dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer) +hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do + withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do + _ <- hClose_help w2_ + withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do + dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer) + withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do + _ <- hClose_help r2_ + withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do + dupHandleTo path h1 (Just w1) r2_ r1_ Nothing +hDuplicateTo h1 _ = + ioe_dupHandlesNotCompatible h1 + + +ioe_dupHandlesNotCompatible :: Handle -> IO a +ioe_dupHandlesNotCompatible h = + ioException (IOError (Just h) IllegalOperation "hDuplicateTo" + "handles are incompatible" Nothing Nothing) + +dupHandleTo :: FilePath + -> Handle + -> Maybe (MVar Handle__) + -> Handle__ + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle__ +dupHandleTo filepath h other_side + hto_@Handle__{haDevice=devTo,..} + h_@Handle__{haDevice=dev} mb_finalizer = do + flushBuffer h_ + case cast devTo of + Nothing -> ioe_dupHandlesNotCompatible h + Just dev' -> do + _ <- IODevice.dup2 dev dev' + FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer + takeMVar m + +-- --------------------------------------------------------------------------- +-- showing Handles. +-- +-- | 'hShow' is in the 'IO' monad, and gives more comprehensive output +-- than the (pure) instance of 'Show' for 'Handle'. + +hShow :: Handle -> IO String +hShow h@(FileHandle path _) = showHandle' path False h +hShow h@(DuplexHandle path _ _) = showHandle' path True h + +showHandle' :: String -> Bool -> Handle -> IO String +showHandle' filepath is_duplex h = + withHandle_ "showHandle" h $ \hdl_ -> + let + showType | is_duplex = showString "duplex (read-write)" + | otherwise = shows (haType hdl_) + in + return + (( showChar '{' . + showHdl (haType hdl_) + (showString "loc=" . showString filepath . showChar ',' . + showString "type=" . showType . showChar ',' . + showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) + ) "") + where + + showHdl :: HandleType -> ShowS -> ShowS + showHdl ht cont = + case ht of + ClosedHandle -> shows ht . showString "}" + _ -> cont + + showBufMode :: Buffer e -> BufferMode -> ShowS + showBufMode buf bmo = + case bmo of + NoBuffering -> showString "none" + LineBuffering -> showString "line" + BlockBuffering (Just n) -> showString "block " . showParen True (shows n) + BlockBuffering Nothing -> showString "block " . showParen True (shows def) + where + def :: Int + def = bufSize buf diff --git a/lib/base/src/GHC/IO/Handle.hs-boot b/lib/base/src/GHC/IO/Handle.hs-boot new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle.hs-boot @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.IO.Handle where + +import GHC.IO +import GHC.IO.Handle.Types + +hFlush :: Handle -> IO () diff --git a/lib/base/src/GHC/IO/Handle/FD.hs b/lib/base/src/GHC/IO/Handle/FD.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle/FD.hs @@ -0,0 +1,274 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.FD +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Handle operations implemented by file descriptors (FDs) +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle.FD ( + stdin, stdout, stderr, + openFile, openBinaryFile, + mkHandleFromFD, fdToHandle, fdToHandle', + isEOF + ) where + +import GHC.Base +import GHC.Num +import GHC.Real +import GHC.Show +import Data.Maybe +-- import Control.Monad +import Foreign.C.Types +import GHC.MVar +import GHC.IO +import GHC.IO.Encoding +-- import GHC.IO.Exception +import GHC.IO.Device as IODevice +import GHC.IO.Exception +import GHC.IO.IOMode +import GHC.IO.Handle +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import GHC.IO.FD (FD(..)) +import qualified GHC.IO.FD as FD +import qualified System.Posix.Internals as Posix + +-- --------------------------------------------------------------------------- +-- Standard Handles + +-- Three handles are allocated during program initialisation. The first +-- two manage input or output from the Haskell program's standard input +-- or output channel respectively. The third manages output to the +-- standard error channel. These handles are initially open. + +-- | A handle managing input from the Haskell program's standard input channel. +stdin :: Handle +{-# NOINLINE stdin #-} +stdin = unsafePerformIO $ do + -- ToDo: acquire lock + setBinaryMode FD.stdin + mkHandle FD.stdin "" ReadHandle True (Just localeEncoding) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +-- | A handle managing output to the Haskell program's standard output channel. +stdout :: Handle +{-# NOINLINE stdout #-} +stdout = unsafePerformIO $ do + -- ToDo: acquire lock + setBinaryMode FD.stdout + mkHandle FD.stdout "" WriteHandle True (Just localeEncoding) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +-- | A handle managing output to the Haskell program's standard error channel. +stderr :: Handle +{-# NOINLINE stderr #-} +stderr = unsafePerformIO $ do + -- ToDo: acquire lock + setBinaryMode FD.stderr + mkHandle FD.stderr "" WriteHandle False{-stderr is unbuffered-} + (Just localeEncoding) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp m = do + h_ <- takeMVar m + flushWriteBuffer h_ + putMVar m (ioe_finalizedHandle fp) + +-- We have to put the FDs into binary mode on Windows to avoid the newline +-- translation that the CRT IO library does. +setBinaryMode :: FD -> IO () +#ifdef mingw32_HOST_OS +setBinaryMode fd = do _ <- setmode (fdFD fd) True + return () +#else +setBinaryMode _ = return () +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "__hscore_setmode" + setmode :: CInt -> Bool -> IO CInt +#endif + +-- --------------------------------------------------------------------------- +-- isEOF + +-- | The computation 'isEOF' is identical to 'hIsEOF', +-- except that it works only on 'stdin'. + +isEOF :: IO Bool +isEOF = hIsEOF stdin + +-- --------------------------------------------------------------------------- +-- Opening and Closing Files + +addFilePathToIOError :: String -> FilePath -> IOException -> IOException +addFilePathToIOError fun fp ioe + = ioe{ ioe_location = fun, ioe_filename = Just fp } + +-- | Computation 'openFile' @file mode@ allocates and returns a new, open +-- handle to manage the file @file@. It manages input if @mode@ +-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', +-- and both input and output if mode is 'ReadWriteMode'. +-- +-- If the file does not exist and it is opened for output, it should be +-- created as a new file. If @mode@ is 'WriteMode' and the file +-- already exists, then it should be truncated to zero length. +-- Some operating systems delete empty files, so there is no guarantee +-- that the file will exist following an 'openFile' with @mode@ +-- 'WriteMode' unless it is subsequently written to successfully. +-- The handle is positioned at the end of the file if @mode@ is +-- 'AppendMode', and otherwise at the beginning (in which case its +-- internal position is 0). +-- The initial buffer mode is implementation-dependent. +-- +-- This operation may fail with: +-- +-- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- +-- * 'isDoesNotExistError' if the file does not exist; or +-- +-- * 'isPermissionError' if the user does not have permission to open the file. +-- +-- Note: if you will be working with files containing binary data, you'll want to +-- be using 'openBinaryFile'. +openFile :: FilePath -> IOMode -> IO Handle +openFile fp im = + catchException + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE) + (\e -> ioError (addFilePathToIOError "openFile" fp e)) + +-- | Like 'openFile', but open the file in binary mode. +-- On Windows, reading a file in text mode (which is the default) +-- will translate CRLF to LF, and writing will translate LF to CRLF. +-- This is usually what you want with text files. With binary files +-- this is undesirable; also, as usual under Microsoft operating systems, +-- text mode treats control-Z as EOF. Binary mode turns off all special +-- treatment of end-of-line and end-of-file characters. +-- (See also 'hSetBinaryMode'.) + +openBinaryFile :: FilePath -> IOMode -> IO Handle +openBinaryFile fp m = + catchException + (openFile' fp m True) + (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + +openFile' :: String -> IOMode -> Bool -> IO Handle +openFile' filepath iomode binary = do + -- first open the file to get an FD + (fd, fd_type) <- FD.openFile filepath iomode + + let mb_codec = if binary then Nothing else Just localeEncoding + + -- then use it to make a Handle + mkHandleFromFD fd fd_type filepath iomode True{-non-blocking-} mb_codec + `onException` IODevice.close fd + -- NB. don't forget to close the FD if mkHandleFromFD fails, otherwise + -- this FD leaks. + -- ASSERT: if we just created the file, then fdToHandle' won't fail + -- (so we don't need to worry about removing the newly created file + -- in the event of an error). + + +-- --------------------------------------------------------------------------- +-- Converting file descriptors to Handles + +mkHandleFromFD + :: FD + -> IODeviceType + -> FilePath -- a string describing this file descriptor (e.g. the filename) + -> IOMode + -> Bool -- non_blocking (*sets* non-blocking mode on the FD) + -> Maybe TextEncoding + -> IO Handle + +mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec + = do +#ifndef mingw32_HOST_OS + -- turn on non-blocking mode + fd <- if set_non_blocking + then FD.setNonBlockingMode fd0 True + else return fd0 +#else + let _ = set_non_blocking -- warning suppression + fd <- return fd0 +#endif + + let nl | isJust mb_codec = nativeNewlineMode + | otherwise = noNewlineTranslation + + case fd_type of + Directory -> + ioException (IOError Nothing InappropriateType "openFile" + "is a directory" Nothing Nothing) + + Stream + -- only *Streams* can be DuplexHandles. Other read/write + -- Handles must share a buffer. + | ReadWriteMode <- iomode -> + mkDuplexHandle fd filepath mb_codec nl + + + _other -> + mkFileHandle fd filepath iomode mb_codec nl + +-- | Old API kept to avoid breaking clients +fdToHandle' :: CInt + -> Maybe IODeviceType + -> Bool -- is_socket on Win, non-blocking on Unix + -> FilePath + -> IOMode + -> Bool -- binary + -> IO Handle +fdToHandle' fdint mb_type is_socket filepath iomode binary = do + let mb_stat = case mb_type of + Nothing -> Nothing + -- mkFD will do the stat: + Just RegularFile -> Nothing + -- no stat required for streams etc.: + Just other -> Just (other,0,0) + (fd,fd_type) <- FD.mkFD (fromIntegral fdint) iomode mb_stat + is_socket + is_socket + mkHandleFromFD fd fd_type filepath iomode is_socket + (if binary then Nothing else Just localeEncoding) + + +-- | Turn an existing file descriptor into a Handle. This is used by +-- various external libraries to make Handles. +-- +-- Makes a binary Handle. This is for historical reasons; it should +-- probably be a text Handle with the default encoding and newline +-- translation instead. +fdToHandle :: Posix.FD -> IO Handle +fdToHandle fdint = do + iomode <- Posix.fdGetMode (fromIntegral fdint) + (fd,fd_type) <- FD.mkFD (fromIntegral fdint) iomode Nothing + False{-is_socket-} + -- NB. the is_socket flag is False, meaning that: + -- on Windows we're guessing this is not a socket (XXX) + False{-is_nonblock-} + -- file descriptors that we get from external sources are + -- not put into non-blocking mode, becuase that would affect + -- other users of the file descriptor + let fd_str = "" + mkHandleFromFD fd fd_type fd_str iomode False{-non-block-} + Nothing -- bin mode + +-- --------------------------------------------------------------------------- +-- Are files opened by default in text or binary mode, if the user doesn't +-- specify? + +dEFAULT_OPEN_IN_BINARY_MODE :: Bool +dEFAULT_OPEN_IN_BINARY_MODE = False diff --git a/lib/base/src/GHC/IO/Handle/FD.hs-boot b/lib/base/src/GHC/IO/Handle/FD.hs-boot new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle/FD.hs-boot @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +module GHC.IO.Handle.FD where + +import GHC.IO.Handle.Types + +-- used in GHC.Conc, which is below GHC.IO.Handle.FD +stdout :: Handle diff --git a/lib/base/src/GHC/IO/Handle/Internals.hs b/lib/base/src/GHC/IO/Handle/Internals.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle/Internals.hs @@ -0,0 +1,850 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -XRecordWildCards #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.Internals +-- Copyright : (c) The University of Glasgow, 1994-2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This module defines the basic operations on I\/O \"handles\". All +-- of the operations defined here are independent of the underlying +-- device. +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO.Handle.Internals ( + withHandle, withHandle', withHandle_, + withHandle__', withHandle_', withAllHandles__, + wantWritableHandle, wantReadableHandle, wantReadableHandle_, + wantSeekableHandle, + + mkHandle, mkFileHandle, mkDuplexHandle, + openTextEncoding, initBufferState, + dEFAULT_CHAR_BUFFER_SIZE, + + flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer, + flushCharBuffer, flushByteReadBuffer, + + readTextDevice, writeTextDevice, readTextDeviceNonBlocking, + decodeByteBuf, + + augmentIOError, + ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, + ioe_finalizedHandle, ioe_bufsiz, + + hClose_help, hLookAhead_, + + HandleFinalizer, handleFinalizer, + + debugIO, + ) where + +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Encoding +import GHC.IO.Handle.Types +import GHC.IO.Buffer +import GHC.IO.BufferedIO (BufferedIO) +import GHC.IO.Exception +import GHC.IO.Device (IODevice, SeekMode(..)) +import qualified GHC.IO.Device as IODevice +import qualified GHC.IO.BufferedIO as Buffered + +import GHC.Conc +import GHC.Real +import GHC.Base +import GHC.Exception +import GHC.Num ( Num(..) ) +import GHC.Show +import GHC.IORef +import GHC.MVar +import Data.Typeable +import Control.Monad +import Data.Maybe +import Foreign +-- import System.IO.Error +import System.Posix.Internals hiding (FD) + +import Foreign.C + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False + +-- --------------------------------------------------------------------------- +-- Creating a new handle + +type HandleFinalizer = FilePath -> MVar Handle__ -> IO () + +newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle +newFileHandle filepath mb_finalizer hc = do + m <- newMVar hc + case mb_finalizer of + Just finalizer -> addMVarFinalizer m (finalizer filepath m) + Nothing -> return () + return (FileHandle filepath m) + +-- --------------------------------------------------------------------------- +-- Working with Handles + +{- +In the concurrent world, handles are locked during use. This is done +by wrapping an MVar around the handle which acts as a mutex over +operations on the handle. + +To avoid races, we use the following bracketing operations. The idea +is to obtain the lock, do some operation and replace the lock again, +whether the operation succeeded or failed. We also want to handle the +case where the thread receives an exception while processing the IO +operation: in these cases we also want to relinquish the lock. + +There are three versions of @withHandle@: corresponding to the three +possible combinations of: + + - the operation may side-effect the handle + - the operation may return a result + +If the operation generates an error or an exception is raised, the +original handle is always replaced. +-} + +{-# INLINE withHandle #-} +withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act +withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act + +withHandle' :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO (Handle__,a)) -> IO a +withHandle' fun h m act = + block $ do + (h',v) <- do_operation fun h act m + checkHandleInvariants h' + putMVar m h' + return v + +{-# INLINE withHandle_ #-} +withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a +withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act +withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act + +withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a +withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do + a <- act h_ + return (h_,a) + +withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () +withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act +withAllHandles__ fun h@(DuplexHandle _ r w) act = do + withHandle__' fun h r act + withHandle__' fun h w act + +withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) + -> IO () +withHandle__' fun h m act = + block $ do + h' <- do_operation fun h act m + checkHandleInvariants h' + putMVar m h' + return () + +do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a +do_operation fun h act m = do + h_ <- takeMVar m + checkHandleInvariants h_ + act h_ `catchException` handler h_ + where + handler h_ e = do + putMVar m h_ + case () of + _ | Just ioe <- fromException e -> + ioError (augmentIOError ioe fun h) + _ | Just async_ex <- fromException e -> do -- see Note [async] + let _ = async_ex :: AsyncException + t <- myThreadId + throwTo t e + do_operation fun h act m + _otherwise -> + throwIO e + +-- Note [async] +-- +-- If an asynchronous exception is raised during an I/O operation, +-- normally it is fine to just re-throw the exception synchronously. +-- However, if we are inside an unsafePerformIO or an +-- unsafeInterleaveIO, this would replace the enclosing thunk with the +-- exception raised, which is wrong (#3997). We have to release the +-- lock on the Handle, but what do we replace the thunk with? What +-- should happen when the thunk is subsequently demanded again? +-- +-- The only sensible choice we have is to re-do the IO operation on +-- resumption, but then we have to be careful in the IO library that +-- this is always safe to do. In particular we should +-- +-- never perform any side-effects before an interruptible operation +-- +-- because the interruptible operation may raise an asynchronous +-- exception, which may cause the operation and its side effects to be +-- subsequently performed again. +-- +-- Re-doing the IO operation is achieved by: +-- - using throwTo to re-throw the asynchronous exception asynchronously +-- in the current thread +-- - on resumption, it will be as if throwTo returns. In that case, we +-- recursively invoke the original operation (see do_operation above). +-- +-- Interruptible operations in the I/O library are: +-- - threadWaitRead/threadWaitWrite +-- - fillReadBuffer/flushWriteBuffer +-- - readTextDevice/writeTextDevice + +augmentIOError :: IOException -> String -> Handle -> IOException +augmentIOError ioe@IOError{ ioe_filename = fp } fun h + = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath } + where filepath + | Just _ <- fp = fp + | otherwise = case h of + FileHandle path _ -> Just path + DuplexHandle path _ _ -> Just path + +-- --------------------------------------------------------------------------- +-- Wrapper for write operations. + +wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantWritableHandle fun h@(FileHandle _ m) act + = wantWritableHandle' fun h m act +wantWritableHandle fun h@(DuplexHandle _ _ m) act + = withHandle_' fun h m act + +wantWritableHandle' + :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO a) -> IO a +wantWritableHandle' fun h m act + = withHandle_' fun h m (checkWritableHandle act) + +checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a +checkWritableHandle act h_@Handle__{..} + = case haType of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + ReadHandle -> ioe_notWritable + ReadWriteHandle -> do + buf <- readIORef haCharBuffer + when (not (isWriteBuffer buf)) $ do + flushCharReadBuffer h_ + flushByteReadBuffer h_ + buf <- readIORef haCharBuffer + writeIORef haCharBuffer buf{ bufState = WriteBuffer } + buf <- readIORef haByteBuffer + buf' <- Buffered.emptyWriteBuffer haDevice buf + writeIORef haByteBuffer buf' + act h_ + _other -> act h_ + +-- --------------------------------------------------------------------------- +-- Wrapper for read operations. + +wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act) + +wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantReadableHandle_ fun h@(FileHandle _ m) act + = wantReadableHandle' fun h m act +wantReadableHandle_ fun h@(DuplexHandle _ m _) act + = withHandle_' fun h m act + +wantReadableHandle' + :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO a) -> IO a +wantReadableHandle' fun h m act + = withHandle_' fun h m (checkReadableHandle act) + +checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a +checkReadableHandle act h_@Handle__{..} = + case haType of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notReadable + WriteHandle -> ioe_notReadable + ReadWriteHandle -> do + -- a read/write handle and we want to read from it. We must + -- flush all buffered write data first. + cbuf <- readIORef haCharBuffer + when (isWriteBuffer cbuf) $ do + cbuf' <- flushWriteBuffer_ h_ cbuf + writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer } + bbuf <- readIORef haByteBuffer + writeIORef haByteBuffer bbuf{ bufState = ReadBuffer } + act h_ + _other -> act h_ + +-- --------------------------------------------------------------------------- +-- Wrapper for seek operations. + +wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = + ioException (IOError (Just h) IllegalOperation fun + "handle is not seekable" Nothing Nothing) +wantSeekableHandle fun h@(FileHandle _ m) act = + withHandle_' fun h m (checkSeekableHandle act) + +checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a +checkSeekableHandle act handle_@Handle__{haDevice=dev} = + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notSeekable + _ -> do b <- IODevice.isSeekable dev + if b then act handle_ + else ioe_notSeekable + +-- ----------------------------------------------------------------------------- +-- Handy IOErrors + +ioe_closedHandle, ioe_EOF, + ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable, + ioe_notSeekable, ioe_invalidCharacter :: IO a + +ioe_closedHandle = ioException + (IOError Nothing IllegalOperation "" + "handle is closed" Nothing Nothing) +ioe_EOF = ioException + (IOError Nothing EOF "" "" Nothing Nothing) +ioe_notReadable = ioException + (IOError Nothing IllegalOperation "" + "handle is not open for reading" Nothing Nothing) +ioe_notWritable = ioException + (IOError Nothing IllegalOperation "" + "handle is not open for writing" Nothing Nothing) +ioe_notSeekable = ioException + (IOError Nothing IllegalOperation "" + "handle is not seekable" Nothing Nothing) +ioe_cannotFlushNotSeekable = ioException + (IOError Nothing IllegalOperation "" + "cannot flush the read buffer: underlying device is not seekable" + Nothing Nothing) +ioe_invalidCharacter = ioException + (IOError Nothing InvalidArgument "" + ("invalid byte sequence for this encoding") Nothing Nothing) + +ioe_finalizedHandle :: FilePath -> Handle__ +ioe_finalizedHandle fp = throw + (IOError Nothing IllegalOperation "" + "handle is finalized" Nothing (Just fp)) + +ioe_bufsiz :: Int -> IO a +ioe_bufsiz n = ioException + (IOError Nothing InvalidArgument "hSetBuffering" + ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) + -- 9 => should be parens'ified. + +-- ----------------------------------------------------------------------------- +-- Handle Finalizers + +-- For a duplex handle, we arrange that the read side points to the write side +-- (and hence keeps it alive if the read side is alive). This is done by +-- having the haOtherSide field of the read side point to the read side. +-- The finalizer is then placed on the write side, and the handle only gets +-- finalized once, when both sides are no longer required. + +-- NOTE about finalized handles: It's possible that a handle can be +-- finalized and then we try to use it later, for example if the +-- handle is referenced from another finalizer, or from a thread that +-- has become unreferenced and then resurrected (arguably in the +-- latter case we shouldn't finalize the Handle...). Anyway, +-- we try to emit a helpful message which is better than nothing. + +handleFinalizer :: FilePath -> MVar Handle__ -> IO () +handleFinalizer fp m = do + handle_ <- takeMVar m + case haType handle_ of + ClosedHandle -> return () + _ -> do flushWriteBuffer handle_ `catchAny` \_ -> return () + -- ignore errors and async exceptions, and close the + -- descriptor anyway... + _ <- hClose_handle_ handle_ + return () + putMVar m (ioe_finalizedHandle fp) + +-- --------------------------------------------------------------------------- +-- Allocating buffers + +-- using an 8k char buffer instead of 32k improved performance for a +-- basic "cat" program by ~30% for me. --SDM +dEFAULT_CHAR_BUFFER_SIZE :: Int +dEFAULT_CHAR_BUFFER_SIZE = dEFAULT_BUFFER_SIZE `div` 4 + +getCharBuffer :: IODevice dev => dev -> BufferState + -> IO (IORef CharBuffer, BufferMode) +getCharBuffer dev state = do + buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + ioref <- newIORef buffer + is_tty <- IODevice.isTerminal dev + + let buffer_mode + | is_tty = LineBuffering + | otherwise = BlockBuffering Nothing + + return (ioref, buffer_mode) + +mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode) +mkUnBuffer state = do + buffer <- case state of -- See [note Buffer Sizing], GHC.IO.Handle.Types + ReadBuffer -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + WriteBuffer -> newCharBuffer 1 state + ref <- newIORef buffer + return (ref, NoBuffering) + +-- ----------------------------------------------------------------------------- +-- Flushing buffers + +-- | syncs the file with the buffer, including moving the +-- file pointer backwards in the case of a read buffer. This can fail +-- on a non-seekable read Handle. +flushBuffer :: Handle__ -> IO () +flushBuffer h_@Handle__{..} = do + buf <- readIORef haCharBuffer + case bufState buf of + ReadBuffer -> do + flushCharReadBuffer h_ + flushByteReadBuffer h_ + WriteBuffer -> do + buf' <- flushWriteBuffer_ h_ buf + writeIORef haCharBuffer buf' + +-- | flushes at least the Char buffer, and the byte buffer for a write +-- Handle. Works on all Handles. +flushCharBuffer :: Handle__ -> IO () +flushCharBuffer h_@Handle__{..} = do + buf <- readIORef haCharBuffer + case bufState buf of + ReadBuffer -> do + flushCharReadBuffer h_ + WriteBuffer -> do + buf' <- flushWriteBuffer_ h_ buf + writeIORef haCharBuffer buf' + +-- ----------------------------------------------------------------------------- +-- Writing data (flushing write buffers) + +-- flushWriteBuffer flushes the buffer iff it contains pending write +-- data. Flushes both the Char and the byte buffer, leaving both +-- empty. +flushWriteBuffer :: Handle__ -> IO () +flushWriteBuffer h_@Handle__{..} = do + buf <- readIORef haCharBuffer + if isWriteBuffer buf + then do buf' <- flushWriteBuffer_ h_ buf + writeIORef haCharBuffer buf' + else return () + +flushWriteBuffer_ :: Handle__ -> CharBuffer -> IO CharBuffer +flushWriteBuffer_ h_@Handle__{..} cbuf = do + bbuf <- readIORef haByteBuffer + if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf) + then do writeTextDevice h_ cbuf + return cbuf{ bufL=0, bufR=0 } + else return cbuf + +-- ----------------------------------------------------------------------------- +-- Flushing read buffers + +-- It is always possible to flush the Char buffer back to the byte buffer. +flushCharReadBuffer :: Handle__ -> IO () +flushCharReadBuffer Handle__{..} = do + cbuf <- readIORef haCharBuffer + if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do + + -- haLastDecode is the byte buffer just before we did our last batch of + -- decoding. We're going to re-decode the bytes up to the current char, + -- to find out where we should revert the byte buffer to. + (codec_state, bbuf0) <- readIORef haLastDecode + + cbuf0 <- readIORef haCharBuffer + writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 } + + -- if we haven't used any characters from the char buffer, then just + -- re-install the old byte buffer. + if bufL cbuf0 == 0 + then do writeIORef haByteBuffer bbuf0 + return () + else do + + case haDecoder of + Nothing -> do + writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 } + -- no decoder: the number of bytes to decode is the same as the + -- number of chars we have used up. + + Just decoder -> do + debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++ + " cbuf=" ++ summaryBuffer cbuf0) + + -- restore the codec state + setState decoder codec_state + + (bbuf1,cbuf1) <- (encode decoder) bbuf0 + cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 } + + debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++ + " cbuf=" ++ summaryBuffer cbuf1) + + writeIORef haByteBuffer bbuf1 + + +-- When flushing the byte read buffer, we seek backwards by the number +-- of characters in the buffer. The file descriptor must therefore be +-- seekable: attempting to flush the read buffer on an unseekable +-- handle is not allowed. + +flushByteReadBuffer :: Handle__ -> IO () +flushByteReadBuffer h_@Handle__{..} = do + bbuf <- readIORef haByteBuffer + + if isEmptyBuffer bbuf then return () else do + + seekable <- IODevice.isSeekable haDevice + when (not seekable) $ ioe_cannotFlushNotSeekable + + let seek = negate (bufR bbuf - bufL bbuf) + + debugIO ("flushByteReadBuffer: new file offset = " ++ show seek) + IODevice.seek haDevice RelativeSeek (fromIntegral seek) + + writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 } + +-- ---------------------------------------------------------------------------- +-- Making Handles + +mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath + -> HandleType + -> Bool -- buffered? + -> Maybe TextEncoding + -> NewlineMode + -> Maybe HandleFinalizer + -> Maybe (MVar Handle__) + -> IO Handle + +mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do + openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do + + let buf_state = initBufferState ha_type + bbuf <- Buffered.newBuffer dev buf_state + bbufref <- newIORef bbuf + last_decode <- newIORef (error "codec_state", bbuf) + + (cbufref,bmode) <- + if buffered then getCharBuffer dev buf_state + else mkUnBuffer buf_state + + spares <- newIORef BufferListNil + newFileHandle filepath finalizer + (Handle__ { haDevice = dev, + haType = ha_type, + haBufferMode = bmode, + haByteBuffer = bbufref, + haLastDecode = last_decode, + haCharBuffer = cbufref, + haBuffers = spares, + haEncoder = mb_encoder, + haDecoder = mb_decoder, + haCodec = mb_codec, + haInputNL = inputNL nl, + haOutputNL = outputNL nl, + haOtherSide = other_side + }) + +-- | makes a new 'Handle' +mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev) + => dev -- ^ the underlying IO device, which must support + -- 'IODevice', 'BufferedIO' and 'Typeable' + -> FilePath + -- ^ a string describing the 'Handle', e.g. the file + -- path for a file. Used in error messages. + -> IOMode + -- The mode in which the 'Handle' is to be used + -> Maybe TextEncoding + -- Create the 'Handle' with no text encoding? + -> NewlineMode + -- Translate newlines? + -> IO Handle +mkFileHandle dev filepath iomode mb_codec tr_newlines = do + mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec + tr_newlines + (Just handleFinalizer) Nothing{-other_side-} + +-- | like 'mkFileHandle', except that a 'Handle' is created with two +-- independent buffers, one for reading and one for writing. Used for +-- full-dupliex streams, such as network sockets. +mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle +mkDuplexHandle dev filepath mb_codec tr_newlines = do + + write_side@(FileHandle _ write_m) <- + mkHandle dev filepath WriteHandle True mb_codec + tr_newlines + (Just handleFinalizer) + Nothing -- no othersie + + read_side@(FileHandle _ read_m) <- + mkHandle dev filepath ReadHandle True mb_codec + tr_newlines + Nothing -- no finalizer + (Just write_m) + + return (DuplexHandle filepath read_m write_m) + +ioModeToHandleType :: IOMode -> HandleType +ioModeToHandleType ReadMode = ReadHandle +ioModeToHandleType WriteMode = WriteHandle +ioModeToHandleType ReadWriteMode = ReadWriteHandle +ioModeToHandleType AppendMode = AppendHandle + +initBufferState :: HandleType -> BufferState +initBufferState ReadHandle = ReadBuffer +initBufferState _ = WriteBuffer + +openTextEncoding + :: Maybe TextEncoding + -> HandleType + -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a) + -> IO a + +openTextEncoding Nothing ha_type cont = cont Nothing Nothing +openTextEncoding (Just TextEncoding{..}) ha_type cont = do + mb_decoder <- if isReadableHandleType ha_type then do + decoder <- mkTextDecoder + return (Just decoder) + else + return Nothing + mb_encoder <- if isWritableHandleType ha_type then do + encoder <- mkTextEncoder + return (Just encoder) + else + return Nothing + cont mb_encoder mb_decoder + +-- --------------------------------------------------------------------------- +-- closing Handles + +-- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when +-- EOF is read or an IO error occurs on a lazy stream. The +-- semi-closed Handle is then closed immediately. We have to be +-- careful with DuplexHandles though: we have to leave the closing to +-- the finalizer in that case, because the write side may still be in +-- use. +hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException) +hClose_help handle_ = + case haType handle_ of + ClosedHandle -> return (handle_,Nothing) + _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible + -- it is important that hClose doesn't fail and + -- leave the Handle open (#3128), so we catch + -- exceptions when flushing the buffer. + (h_, mb_exc2) <- hClose_handle_ handle_ + return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2) + + +trymaybe :: IO () -> IO (Maybe SomeException) +trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e) + +hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) +hClose_handle_ Handle__{..} = do + + -- close the file descriptor, but not when this is the read + -- side of a duplex handle. + -- If an exception is raised by the close(), we want to continue + -- to close the handle and release the lock if it has one, then + -- we return the exception to the caller of hClose_help which can + -- raise it if necessary. + maybe_exception <- + case haOtherSide of + Nothing -> trymaybe $ IODevice.close haDevice + Just _ -> return Nothing + + -- free the spare buffers + writeIORef haBuffers BufferListNil + writeIORef haCharBuffer noCharBuffer + writeIORef haByteBuffer noByteBuffer + + -- release our encoder/decoder + case haDecoder of Nothing -> return (); Just d -> close d + case haEncoder of Nothing -> return (); Just d -> close d + + -- we must set the fd to -1, because the finalizer is going + -- to run eventually and try to close/unlock it. + -- ToDo: necessary? the handle will be marked ClosedHandle + -- XXX GHC won't let us use record update here, hence wildcards + return (Handle__{ haType = ClosedHandle, .. }, maybe_exception) + +{-# NOINLINE noCharBuffer #-} +noCharBuffer :: CharBuffer +noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer + +{-# NOINLINE noByteBuffer #-} +noByteBuffer :: Buffer Word8 +noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer + +-- --------------------------------------------------------------------------- +-- Looking ahead + +hLookAhead_ :: Handle__ -> IO Char +hLookAhead_ handle_@Handle__{..} = do + buf <- readIORef haCharBuffer + + -- fill up the read buffer if necessary + new_buf <- if isEmptyBuffer buf + then readTextDevice handle_ buf + else return buf + writeIORef haCharBuffer new_buf + + peekCharBuf (bufRaw buf) (bufL buf) + +-- --------------------------------------------------------------------------- +-- debugging + +debugIO :: String -> IO () +debugIO s + | c_DEBUG_DUMP + = do _ <- withCStringLen (s ++ "\n") $ + \(p, len) -> c_write 1 (castPtr p) (fromIntegral len) + return () + | otherwise = return () + +-- ---------------------------------------------------------------------------- +-- Text input/output + +-- Write the contents of the supplied Char buffer to the device, return +-- only when all the data has been written. +writeTextDevice :: Handle__ -> CharBuffer -> IO () +writeTextDevice h_@Handle__{..} cbuf = do + -- + bbuf <- readIORef haByteBuffer + + debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++ + " bbuf=" ++ summaryBuffer bbuf) + + (cbuf',bbuf') <- case haEncoder of + Nothing -> latin1_encode cbuf bbuf + Just encoder -> (encode encoder) cbuf bbuf + + debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf') + + bbuf' <- Buffered.flushWriteBuffer haDevice bbuf' + writeIORef haByteBuffer bbuf' + if not (isEmptyBuffer cbuf') + then writeTextDevice h_ cbuf' + else return () + +-- Read characters into the provided buffer. Return when any +-- characters are available; raise an exception if the end of +-- file is reached. +readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer +readTextDevice h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer + + debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++ + " bbuf=" ++ summaryBuffer bbuf0) + + bbuf1 <- if not (isEmptyBuffer bbuf0) + then return bbuf0 + else do + (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0 + if r == 0 then ioe_EOF else do -- raise EOF + return bbuf1 + + debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1) + + (bbuf2,cbuf') <- + case haDecoder of + Nothing -> do + writeIORef haLastDecode (error "codec_state", bbuf1) + latin1_decode bbuf1 cbuf + Just decoder -> do + state <- getState decoder + writeIORef haLastDecode (state, bbuf1) + (encode decoder) bbuf1 cbuf + + debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf2) + + writeIORef haByteBuffer bbuf2 + if bufR cbuf' == bufR cbuf -- no new characters + then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char + else return cbuf' + +-- we have an incomplete byte sequence at the end of the buffer: try to +-- read more bytes. +readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer +readTextDevice' h_@Handle__{..} bbuf0 cbuf = do + -- + -- copy the partial sequence to the beginning of the buffer, so we have + -- room to read more bytes. + bbuf1 <- slideContents bbuf0 + + bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1 + if r == 0 + then ioe_invalidCharacter + else return bbuf2 + + debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2) + + (bbuf3,cbuf') <- + case haDecoder of + Nothing -> do + writeIORef haLastDecode (error "codec_state", bbuf2) + latin1_decode bbuf2 cbuf + Just decoder -> do + state <- getState decoder + writeIORef haLastDecode (state, bbuf2) + (encode decoder) bbuf2 cbuf + + debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf3) + + writeIORef haByteBuffer bbuf3 + if bufR cbuf == bufR cbuf' + then readTextDevice' h_ bbuf3 cbuf' + else return cbuf' + +-- Read characters into the provided buffer. Do not block; +-- return zero characters instead. Raises an exception on end-of-file. +readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer +readTextDeviceNonBlocking h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer + when (isEmptyBuffer bbuf0) $ do + (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0 + if isNothing r then ioe_EOF else do -- raise EOF + writeIORef haByteBuffer bbuf1 + + decodeByteBuf h_ cbuf + +-- Decode bytes from the byte buffer into the supplied CharBuffer. +decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer +decodeByteBuf h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer + + (bbuf2,cbuf') <- + case haDecoder of + Nothing -> do + writeIORef haLastDecode (error "codec_state", bbuf0) + latin1_decode bbuf0 cbuf + Just decoder -> do + state <- getState decoder + writeIORef haLastDecode (state, bbuf0) + (encode decoder) bbuf0 cbuf + + writeIORef haByteBuffer bbuf2 + return cbuf' diff --git a/lib/base/src/GHC/IO/Handle/Text.hs b/lib/base/src/GHC/IO/Handle/Text.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle/Text.hs @@ -0,0 +1,1035 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Text +-- Copyright : (c) The University of Glasgow, 1992-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- String I\/O functions +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO.Handle.Text ( + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + commitBuffer', -- hack, see below + hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, + memcpy, + ) where + +import GHC.IO +import GHC.IO.FD +import GHC.IO.Buffer +import qualified GHC.IO.BufferedIO as Buffered +import GHC.IO.Exception +import GHC.Exception +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import qualified GHC.IO.Device as IODevice +import qualified GHC.IO.Device as RawIO + +import Foreign +import Foreign.C + +import Data.Typeable +import System.IO.Error +import Data.Maybe +import Control.Monad + +import GHC.IORef +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.Show +import GHC.List + +-- --------------------------------------------------------------------------- +-- Simple input operations + +-- If hWaitForInput finds anything in the Handle's buffer, it +-- immediately returns. If not, it tries to read from the underlying +-- OS handle. Notice that for buffered Handles connected to terminals +-- this means waiting until a complete line is available. + +-- | Computation 'hWaitForInput' @hdl t@ +-- waits until input is available on handle @hdl@. +-- It returns 'True' as soon as input is available on @hdl@, +-- or 'False' if no input is available within @t@ milliseconds. Note that +-- 'hWaitForInput' waits until one or more full /characters/ are available, +-- which means that it needs to do decoding, and hence may fail +-- with a decoding error. +-- +-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. +-- * a decoding error, if the input begins with an invalid byte sequence +-- in this Handle's encoding. +-- +-- NOTE for GHC users: unless you use the @-threaded@ flag, +-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell +-- threads for the duration of the call. It behaves like a +-- @safe@ foreign call in this respect. +-- + +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput h msecs = do + wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do + cbuf <- readIORef haCharBuffer + + if not (isEmptyBuffer cbuf) then return True else do + + if msecs < 0 + then do cbuf' <- readTextDevice handle_ cbuf + writeIORef haCharBuffer cbuf' + return True + else do + -- there might be bytes in the byte buffer waiting to be decoded + cbuf' <- decodeByteBuf handle_ cbuf + writeIORef haCharBuffer cbuf' + + if not (isEmptyBuffer cbuf') then return True else do + + r <- IODevice.ready haDevice False{-read-} msecs + if r then do -- Call hLookAhead' to throw an EOF + -- exception if appropriate + _ <- hLookAhead_ handle_ + return True + else return False + -- XXX we should only return when there are full characters + -- not when there are only bytes. That would mean looping + -- and re-running IODevice.ready if we don't have any full + -- characters; but we don't know how long we've waited + -- so far. + +-- --------------------------------------------------------------------------- +-- hGetChar + +-- | Computation 'hGetChar' @hdl@ reads a character from the file or +-- channel managed by @hdl@, blocking until a character is available. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hGetChar :: Handle -> IO Char +hGetChar handle = + wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do + + -- buffering mode makes no difference: we just read whatever is available + -- from the device (blocking only if there is nothing available), and then + -- return the first character. + -- See [note Buffered Reading] in GHC.IO.Handle.Types + buf0 <- readIORef haCharBuffer + + buf1 <- if isEmptyBuffer buf0 + then readTextDevice handle_ buf0 + else return buf0 + + (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1) + let buf2 = bufferAdjustL i buf1 + + if haInputNL == CRLF && c1 == '\r' + then do + mbuf3 <- if isEmptyBuffer buf2 + then maybeFillReadBuffer handle_ buf2 + else return (Just buf2) + + case mbuf3 of + -- EOF, so just return the '\r' we have + Nothing -> do + writeIORef haCharBuffer buf2 + return '\r' + Just buf3 -> do + (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2) + if c2 == '\n' + then do + writeIORef haCharBuffer (bufferAdjustL i2 buf3) + return '\n' + else do + -- not a \r\n sequence, so just return the \r + writeIORef haCharBuffer buf3 + return '\r' + else do + writeIORef haCharBuffer buf2 + return c1 + +-- --------------------------------------------------------------------------- +-- hGetLine + +-- | Computation 'hGetLine' @hdl@ reads a line from the file or +-- channel managed by @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file is encountered when reading +-- the /first/ character of the line. +-- +-- If 'hGetLine' encounters end-of-file at any other point while reading +-- in a line, it is treated as a line terminator and the (partial) +-- line is returned. + +hGetLine :: Handle -> IO String +hGetLine h = + wantReadableHandle_ "hGetLine" h $ \ handle_ -> do + hGetLineBuffered handle_ + +hGetLineBuffered :: Handle__ -> IO String +hGetLineBuffered handle_@Handle__{..} = do + buf <- readIORef haCharBuffer + hGetLineBufferedLoop handle_ buf [] + +hGetLineBufferedLoop :: Handle__ + -> CharBuffer -> [String] + -> IO String +hGetLineBufferedLoop handle_@Handle__{..} + buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss = + let + -- find the end-of-line character, if there is one + loop raw r + | r == w = return (False, w) + | otherwise = do + (c,r') <- readCharBuf raw r + if c == '\n' + then return (True, r) -- NB. not r': don't include the '\n' + else loop raw r' + in do + (eol, off) <- loop raw0 r0 + + debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off) + + (xs,r') <- if haInputNL == CRLF + then unpack_nl raw0 r0 off "" + else do xs <- unpack raw0 r0 off "" + return (xs,off) + + -- if eol == True, then off is the offset of the '\n' + -- otherwise off == w and the buffer is now empty. + if eol -- r' == off + then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf) + return (concat (reverse (xs:xss))) + else do + let buf1 = bufferAdjustL r' buf + maybe_buf <- maybeFillReadBuffer handle_ buf1 + case maybe_buf of + -- Nothing indicates we caught an EOF, and we may have a + -- partial line to return. + Nothing -> do + -- we reached EOF. There might be a lone \r left + -- in the buffer, so check for that and + -- append it to the line if necessary. + -- + let pre = if not (isEmptyBuffer buf1) then "\r" else "" + writeIORef haCharBuffer buf1{ bufL=0, bufR=0 } + let str = concat (reverse (pre:xs:xss)) + if not (null str) + then return str + else ioe_EOF + Just new_buf -> + hGetLineBufferedLoop handle_ new_buf (xs:xss) + +maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) +maybeFillReadBuffer handle_ buf + = catch + (do buf' <- getSomeCharacters handle_ buf + return (Just buf') + ) + (\e -> do if isEOFError e + then return Nothing + else ioError e) + +-- See GHC.IO.Buffer +#define CHARBUF_UTF32 +-- #define CHARBUF_UTF16 + +-- NB. performance-critical code: eyeball the Core. +unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char] +unpack !buf !r !w acc0 + | r == w = return acc0 + | otherwise = + withRawBuffer buf $ \pbuf -> + let + unpackRB acc !i + | i < r = return acc + | otherwise = do +#ifdef CHARBUF_UTF16 + -- reverse-order decoding of UTF-16 + c2 <- peekElemOff pbuf i + if (c2 < 0xdc00 || c2 > 0xdffff) + then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1) + else do c1 <- peekElemOff pbuf (i-1) + let c = (fromIntegral c1 - 0xd800) * 0x400 + + (fromIntegral c2 - 0xdc00) + 0x10000 + unpackRB (unsafeChr c : acc) (i-2) +#else + c <- peekElemOff pbuf i + unpackRB (c:acc) (i-1) +#endif + in + unpackRB acc0 (w-1) + +-- NB. performance-critical code: eyeball the Core. +unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int) +unpack_nl !buf !r !w acc0 + | r == w = return (acc0, 0) + | otherwise = + withRawBuffer buf $ \pbuf -> + let + unpackRB acc !i + | i < r = return acc + | otherwise = do + c <- peekElemOff pbuf i + if (c == '\n' && i > r) + then do + c1 <- peekElemOff pbuf (i-1) + if (c1 == '\r') + then unpackRB ('\n':acc) (i-2) + else unpackRB ('\n':acc) (i-1) + else do + unpackRB (c:acc) (i-1) + in do + c <- peekElemOff pbuf (w-1) + if (c == '\r') + then do + -- If the last char is a '\r', we need to know whether or + -- not it is followed by a '\n', so leave it in the buffer + -- for now and just unpack the rest. + str <- unpackRB acc0 (w-2) + return (str, w-1) + else do + str <- unpackRB acc0 (w-1) + return (str, w) + + +-- ----------------------------------------------------------------------------- +-- hGetContents + +-- hGetContents on a DuplexHandle only affects the read side: you can +-- carry on writing to it afterwards. + +-- | Computation 'hGetContents' @hdl@ returns the list of characters +-- corresponding to the unread portion of the channel or file managed +-- by @hdl@, which is put into an intermediate state, /semi-closed/. +-- In this state, @hdl@ is effectively closed, +-- but items are read from @hdl@ on demand and accumulated in a special +-- list returned by 'hGetContents' @hdl@. +-- +-- Any operation that fails because a handle is closed, +-- also fails if a handle is semi-closed. The only exception is 'hClose'. +-- A semi-closed handle becomes closed: +-- +-- * if 'hClose' is applied to it; +-- +-- * if an I\/O error occurs when reading an item from the handle; +-- +-- * or once the entire contents of the handle has been read. +-- +-- Once a semi-closed handle becomes closed, the contents of the +-- associated list becomes fixed. The contents of this final list is +-- only partially specified: it will contain at least all the items of +-- the stream that were evaluated prior to the handle becoming closed. +-- +-- Any I\/O errors encountered while a handle is semi-closed are simply +-- discarded. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hGetContents :: Handle -> IO String +hGetContents handle = + wantReadableHandle "hGetContents" handle $ \handle_ -> do + xs <- lazyRead handle + return (handle_{ haType=SemiClosedHandle}, xs ) + +-- Note that someone may close the semi-closed handle (or change its +-- buffering), so each time these lazy read functions are pulled on, +-- they have to check whether the handle has indeed been closed. + +lazyRead :: Handle -> IO String +lazyRead handle = + unsafeInterleaveIO $ + withHandle "hGetContents" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return (handle_, "") + SemiClosedHandle -> lazyReadBuffered handle handle_ + _ -> ioException + (IOError (Just handle) IllegalOperation "hGetContents" + "illegal handle type" Nothing Nothing) + +lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) +lazyReadBuffered h handle_@Handle__{..} = do + buf <- readIORef haCharBuffer + catch + (do + buf'@Buffer{..} <- getSomeCharacters handle_ buf + lazy_rest <- lazyRead h + (s,r) <- if haInputNL == CRLF + then unpack_nl bufRaw bufL bufR lazy_rest + else do s <- unpack bufRaw bufL bufR lazy_rest + return (s,bufR) + writeIORef haCharBuffer (bufferAdjustL r buf') + return (handle_, s) + ) + (\e -> do (handle_', _) <- hClose_help handle_ + debugIO ("hGetContents caught: " ++ show e) + -- We might have a \r cached in CRLF mode. So we + -- need to check for that and return it: + let r = if isEOFError e + then if not (isEmptyBuffer buf) + then "\r" + else "" + else + throw (augmentIOError e "hGetContents" h) + + return (handle_', r) + ) + +-- ensure we have some characters in the buffer +getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer +getSomeCharacters handle_@Handle__{..} buf@Buffer{..} = + case bufferElems buf of + + -- buffer empty: read some more + 0 -> readTextDevice handle_ buf + + -- if the buffer has a single '\r' in it and we're doing newline + -- translation: read some more + 1 | haInputNL == CRLF -> do + (c,_) <- readCharBuf bufRaw bufL + if c == '\r' + then do -- shuffle the '\r' to the beginning. This is only safe + -- if we're about to call readTextDevice, otherwise it + -- would mess up flushCharBuffer. + -- See [note Buffer Flushing], GHC.IO.Handle.Types + _ <- writeCharBuf bufRaw 0 '\r' + let buf' = buf{ bufL=0, bufR=1 } + readTextDevice handle_ buf' + else do + return buf + + -- buffer has some chars in it already: just return it + _otherwise -> + return buf + +-- --------------------------------------------------------------------------- +-- hPutChar + +-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the +-- file or channel managed by @hdl@. Characters may be buffered if +-- buffering is enabled for @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; or +-- +-- * 'isPermissionError' if another system resource limit would be exceeded. + +hPutChar :: Handle -> Char -> IO () +hPutChar handle c = do + c `seq` return () + wantWritableHandle "hPutChar" handle $ \ handle_ -> do + case haBufferMode handle_ of + LineBuffering -> hPutcBuffered handle_ True c + _other -> hPutcBuffered handle_ False c + +hPutcBuffered :: Handle__ -> Bool -> Char -> IO () +hPutcBuffered handle_@Handle__{..} is_line c = do + buf <- readIORef haCharBuffer + if c == '\n' + then do buf1 <- if haOutputNL == CRLF + then do + buf1 <- putc buf '\r' + putc buf1 '\n' + else do + putc buf '\n' + if is_line + then do + flushed_buf <- flushWriteBuffer_ handle_ buf1 + writeIORef haCharBuffer flushed_buf + else + writeIORef haCharBuffer buf1 + else do + buf1 <- putc buf c + writeIORef haCharBuffer buf1 + where + putc buf@Buffer{ bufRaw=raw, bufR=w } c = do + debugIO ("putc: " ++ summaryBuffer buf) + w' <- writeCharBuf raw w c + let buf' = buf{ bufR = w' } + if isFullCharBuffer buf' + then flushWriteBuffer_ handle_ buf' + else return buf' + +-- --------------------------------------------------------------------------- +-- hPutStr + +-- We go to some trouble to avoid keeping the handle locked while we're +-- evaluating the string argument to hPutStr, in case doing so triggers another +-- I/O operation on the same handle which would lead to deadlock. The classic +-- case is +-- +-- putStr (trace "hello" "world") +-- +-- so the basic scheme is this: +-- +-- * copy the string into a fresh buffer, +-- * "commit" the buffer to the handle. +-- +-- Committing may involve simply copying the contents of the new +-- buffer into the handle's buffer, flushing one or both buffers, or +-- maybe just swapping the buffers over (if the handle's buffer was +-- empty). See commitBuffer below. + +-- | Computation 'hPutStr' @hdl s@ writes the string +-- @s@ to the file or channel managed by @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; or +-- +-- * 'isPermissionError' if another system resource limit would be exceeded. + +hPutStr :: Handle -> String -> IO () +hPutStr handle str = do + (buffer_mode, nl) <- + wantWritableHandle "hPutStr" handle $ \h_ -> do + bmode <- getSpareBuffer h_ + return (bmode, haOutputNL h_) + + case buffer_mode of + (NoBuffering, _) -> do + hPutChars handle str -- v. slow, but we don't care + (LineBuffering, buf) -> do + writeBlocks handle True nl buf str + (BlockBuffering _, buf) -> do + writeBlocks handle False nl buf str + +hPutChars :: Handle -> [Char] -> IO () +hPutChars _ [] = return () +hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs + +getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer) +getSpareBuffer Handle__{haCharBuffer=ref, + haBuffers=spare_ref, + haBufferMode=mode} + = do + case mode of + NoBuffering -> return (mode, error "no buffer!") + _ -> do + bufs <- readIORef spare_ref + buf <- readIORef ref + case bufs of + BufferListCons b rest -> do + writeIORef spare_ref rest + return ( mode, emptyBuffer b (bufSize buf) WriteBuffer) + BufferListNil -> do + new_buf <- newCharBuffer (bufSize buf) WriteBuffer + return (mode, new_buf) + + +-- NB. performance-critical code: eyeball the Core. +writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO () +writeBlocks hdl line_buffered nl + buf@Buffer{ bufRaw=raw, bufSize=len } s = + let + shoveString :: Int -> [Char] -> IO () + shoveString !n [] = do + _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-} + return () + shoveString !n (c:cs) + -- n+1 so we have enough room to write '\r\n' if necessary + | n + 1 >= len = do + new_buf <- commitBuffer hdl raw len n True{-needs flush-} False + writeBlocks hdl line_buffered nl new_buf (c:cs) + | c == '\n' = do + n' <- if nl == CRLF + then do + n1 <- writeCharBuf raw n '\r' + writeCharBuf raw n1 '\n' + else do + writeCharBuf raw n c + if line_buffered + then do + new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False + writeBlocks hdl line_buffered nl new_buf cs + else do + shoveString n' cs + | otherwise = do + n' <- writeCharBuf raw n c + shoveString n' cs + in + shoveString 0 s + +-- ----------------------------------------------------------------------------- +-- commitBuffer handle buf sz count flush release +-- +-- Write the contents of the buffer 'buf' ('sz' bytes long, containing +-- 'count' bytes of data) to handle (handle must be block or line buffered). +-- +-- Implementation: +-- +-- for block/line buffering, +-- 1. If there isn't room in the handle buffer, flush the handle +-- buffer. +-- +-- 2. If the handle buffer is empty, +-- if flush, +-- then write buf directly to the device. +-- else swap the handle buffer with buf. +-- +-- 3. If the handle buffer is non-empty, copy buf into the +-- handle buffer. Then, if flush != 0, flush +-- the buffer. + +commitBuffer + :: Handle -- handle to commit to + -> RawCharBuffer -> Int -- address and size (in bytes) of buffer + -> Int -- number of bytes of data in buffer + -> Bool -- True <=> flush the handle afterward + -> Bool -- release the buffer? + -> IO CharBuffer + +commitBuffer hdl !raw !sz !count flush release = + wantWritableHandle "commitAndReleaseBuffer" hdl $ + commitBuffer' raw sz count flush release +{-# NOINLINE commitBuffer #-} + +-- Explicitly lambda-lift this function to subvert GHC's full laziness +-- optimisations, which otherwise tends to float out subexpressions +-- past the \handle, which is really a pessimisation in this case because +-- that lambda is a one-shot lambda. +-- +-- Don't forget to export the function, to stop it being inlined too +-- (this appears to be better than NOINLINE, because the strictness +-- analyser still gets to worker-wrapper it). +-- +-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 +-- +commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__ + -> IO CharBuffer +commitBuffer' raw sz@(I# _) count@(I# _) flush release + handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do + + debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count + ++ ", flush=" ++ show flush ++ ", release=" ++ show release) + + old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size } + <- readIORef ref + + buf_ret <- + -- enough room in handle buffer? + if (not flush && (size - w > count)) + -- The > is to be sure that we never exactly fill + -- up the buffer, which would require a flush. So + -- if copying the new data into the buffer would + -- make the buffer full, we just flush the existing + -- buffer and the new data immediately, rather than + -- copying before flushing. + + -- not flushing, and there's enough room in the buffer: + -- just copy the data in and update bufR. + then do withRawBuffer raw $ \praw -> + copyToRawBuffer old_raw (w*charSize) + praw (fromIntegral (count*charSize)) + writeIORef ref old_buf{ bufR = w + count } + return (emptyBuffer raw sz WriteBuffer) + + -- else, we have to flush + else do flushed_buf <- flushWriteBuffer_ handle_ old_buf + + let this_buf = + Buffer{ bufRaw=raw, bufState=WriteBuffer, + bufL=0, bufR=count, bufSize=sz } + + -- if: (a) we don't have to flush, and + -- (b) size(new buffer) == size(old buffer), and + -- (c) new buffer is not full, + -- we can just just swap them over... + if (not flush && sz == size && count /= sz) + then do + writeIORef ref this_buf + return flushed_buf + + -- otherwise, we have to flush the new data too, + -- and start with a fresh buffer + else do + -- We're aren't going to use this buffer again + -- so we ignore the result of flushWriteBuffer_ + _ <- flushWriteBuffer_ handle_ this_buf + writeIORef ref flushed_buf + -- if the sizes were different, then allocate + -- a new buffer of the correct size. + if sz == size + then return (emptyBuffer raw sz WriteBuffer) + else newCharBuffer size WriteBuffer + + -- release the buffer if necessary + case buf_ret of + Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do + if release && buf_ret_sz == size + then do + spare_bufs <- readIORef spare_buf_ref + writeIORef spare_buf_ref + (BufferListCons buf_ret_raw spare_bufs) + return buf_ret + else + return buf_ret + +-- --------------------------------------------------------------------------- +-- Reading/writing sequences of bytes. + +-- --------------------------------------------------------------------------- +-- hPutBuf + +-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the +-- buffer @buf@ to the handle @hdl@. It returns (). +-- +-- 'hPutBuf' ignores any text encoding that applies to the 'Handle', +-- writing the bytes directly to the underlying file or device. +-- +-- 'hPutBuf' ignores the prevailing 'TextEncoding' and +-- 'NewlineMode' on the 'Handle', and writes bytes directly. +-- +-- This operation may fail with: +-- +-- * 'ResourceVanished' if the handle is a pipe or socket, and the +-- reading end is closed. (If this is a POSIX system, and the program +-- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered +-- instead, whose default action is to terminate the program). + +hPutBuf :: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> IO () +hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True + return () + +hPutBufNonBlocking + :: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> IO Int -- returns: number of bytes written +hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False + +hPutBuf':: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> Bool -- allow blocking? + -> IO Int +hPutBuf' handle ptr count can_block + | count == 0 = return 0 + | count < 0 = illegalBufferSize handle "hPutBuf" count + | otherwise = + wantWritableHandle "hPutBuf" handle $ + \ h_@Handle__{..} -> do + debugIO ("hPutBuf count=" ++ show count) + -- first flush the Char buffer if it is non-empty, then we + -- can work directly with the byte buffer + cbuf <- readIORef haCharBuffer + when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_ + + r <- bufWrite h_ (castPtr ptr) count can_block + + -- we must flush if this Handle is set to NoBuffering. If + -- it is set to LineBuffering, be conservative and flush + -- anyway (we didn't check for newlines in the data). + case haBufferMode of + BlockBuffering _ -> do return () + _line_or_no_buffering -> do flushWriteBuffer h_ + return r + +bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int +bufWrite h_@Handle__{..} ptr count can_block = + seq count $ do -- strictness hack + old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size } + <- readIORef haByteBuffer + + -- enough room in handle buffer? + if (size - w > count) + -- There's enough room in the buffer: + -- just copy the data in and update bufR. + then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w) + copyToRawBuffer old_raw w ptr (fromIntegral count) + writeIORef haByteBuffer old_buf{ bufR = w + count } + return count + + -- else, we have to flush + else do debugIO "hPutBuf: flushing first" + old_buf' <- Buffered.flushWriteBuffer haDevice old_buf + -- TODO: we should do a non-blocking flush here + writeIORef haByteBuffer old_buf' + -- if we can fit in the buffer, then just loop + if count < size + then bufWrite h_ ptr count can_block + else if can_block + then do writeChunk h_ (castPtr ptr) count + return count + else writeChunkNonBlocking h_ (castPtr ptr) count + +writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO () +writeChunk h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes + | otherwise = error "Todo: hPutBuf" + +writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int +writeChunkNonBlocking h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes + | otherwise = error "Todo: hPutBuf" + +-- --------------------------------------------------------------------------- +-- hGetBuf + +-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@ until either EOF is reached or +-- @count@ 8-bit bytes have been read. +-- It returns the number of bytes actually read. This may be zero if +-- EOF was reached before any data was read (or if @count@ is zero). +-- +-- 'hGetBuf' never raises an EOF exception, instead it returns a value +-- smaller than @count@. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBuf' will behave as if EOF was reached. +-- +-- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- on the 'Handle', and reads bytes directly. + +hGetBuf :: Handle -> Ptr a -> Int -> IO Int +hGetBuf h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBuf" count + | otherwise = + wantReadableHandle_ "hGetBuf" h $ \ h_ -> do + flushCharReadBuffer h_ + bufRead h_ (castPtr ptr) 0 count + +-- small reads go through the buffer, large reads are satisfied by +-- taking data first from the buffer and then direct from the file +-- descriptor. +bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int +bufRead h_@Handle__{..} ptr so_far count = + seq so_far $ seq count $ do -- strictness hack + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then if count > sz -- small read? + then do rest <- readChunk h_ ptr count + return (so_far + rest) + else do (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return so_far + else do writeIORef haByteBuffer buf' + bufRead h_ ptr so_far count + else do + let avail = w - r + if (count == avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + return (so_far + count) + else do + if (count < avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufL = r + count } + return (so_far + count) + else do + + copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + let remaining = count - avail + so_far' = so_far + avail + ptr' = ptr `plusPtr` avail + + if remaining < sz + then bufRead h_ ptr' so_far' remaining + else do + + rest <- readChunk h_ ptr' remaining + return (so_far' + rest) + +readChunk :: Handle__ -> Ptr a -> Int -> IO Int +readChunk h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = loop fd 0 bytes + | otherwise = error "ToDo: hGetBuf" + where + loop :: FD -> Int -> Int -> IO Int + loop fd off bytes | bytes <= 0 = return off + loop fd off bytes = do + r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes) + if r == 0 + then return off + else loop fd (off + r) (bytes - r) + +-- --------------------------------------------------------------------------- +-- hGetBufSome + +-- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@. If there is any data available to read, +-- then 'hGetBufSome' returns it immediately; it only blocks if there +-- is no data to be read. +-- +-- It returns the number of bytes actually read. This may be zero if +-- EOF was reached before any data was read (or if @count@ is zero). +-- +-- 'hGetBufSome' never raises an EOF exception, instead it returns a value +-- smaller than @count@. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBufSome' will behave as if EOF was reached. +-- +-- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- on the 'Handle', and reads bytes directly. + +hGetBufSome :: Handle -> Ptr a -> Int -> IO Int +hGetBufSome h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBuf" count + | otherwise = + wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do + flushCharReadBuffer h_ + buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then if count > sz -- large read? + then do RawIO.read (haFD h_) (castPtr ptr) count + else do (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return 0 + else do writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 count + else + bufReadNBEmpty h_ buf (castPtr ptr) 0 count + +haFD :: Handle__ -> FD +haFD h_@Handle__{..} = + case cast haDevice of + Nothing -> error "not an FD" + Just fd -> fd + +-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@ until either EOF is reached, or +-- @count@ 8-bit bytes have been read, or there is no more data available +-- to read immediately. +-- +-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will +-- never block waiting for data to become available, instead it returns +-- only whatever data is available. To wait for data to arrive before +-- calling 'hGetBufNonBlocking', use 'hWaitForInput'. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. +-- +-- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and +-- 'NewlineMode' on the 'Handle', and reads bytes directly. + +hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int +hGetBufNonBlocking h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count + | otherwise = + wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do + flushCharReadBuffer h_ + bufReadNonBlocking h_ (castPtr ptr) 0 count + +bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNonBlocking h_@Handle__{..} ptr so_far count = + seq so_far $ seq count $ do -- strictness hack + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then bufReadNBEmpty h_ buf ptr so_far count + else bufReadNBNonEmpty h_ buf ptr so_far count + +bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNBEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + = if count > sz -- large read? + then do rest <- readChunkNonBlocking h_ ptr count + return (so_far + rest) + else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf + case r of + Nothing -> return so_far + Just 0 -> return so_far + Just r -> do + writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' ptr so_far (min count r) + -- NOTE: new count is min count w' + -- so we will just copy the contents of the + -- buffer in the recursive call, and not + -- loop again. + +bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNBNonEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + = do + let avail = w - r + if (count == avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + return (so_far + count) + else do + if (count < avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufL = r + count } + return (so_far + count) + else do + + copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) + let buf' = buf{ bufR=0, bufL=0 } + writeIORef haByteBuffer buf' + let remaining = count - avail + so_far' = so_far + avail + ptr' = ptr `plusPtr` avail + + bufReadNBEmpty h_ buf' ptr' so_far' remaining + + +readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int +readChunkNonBlocking h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = do + m <- RawIO.readNonBlocking (fd::FD) ptr bytes + case m of + Nothing -> return 0 + Just n -> return n + | otherwise = error "ToDo: hGetBuf" + +-- --------------------------------------------------------------------------- +-- memcpy wrappers + +copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO () +copyToRawBuffer raw off ptr bytes = + withRawBuffer raw $ \praw -> + do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes) + return () + +copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO () +copyFromRawBuffer ptr raw off bytes = + withRawBuffer raw $ \praw -> + do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes) + return () + +foreign import ccall unsafe "memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ()) + +----------------------------------------------------------------------------- +-- Internal Utils + +illegalBufferSize :: Handle -> String -> Int -> IO a +illegalBufferSize handle fn sz = + ioException (IOError (Just handle) + InvalidArgument fn + ("illegal buffer size " ++ showsPrec 9 sz []) + Nothing Nothing) diff --git a/lib/base/src/GHC/IO/Handle/Types.hs b/lib/base/src/GHC/IO/Handle/Types.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/Handle/Types.hs @@ -0,0 +1,402 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.Types +-- Copyright : (c) The University of Glasgow, 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Basic types for the implementation of IO Handles. +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle.Types ( + Handle(..), Handle__(..), showHandle, + checkHandleInvariants, + BufferList(..), + HandleType(..), + isReadableHandleType, isWritableHandleType, isReadWriteHandleType, + BufferMode(..), + BufferCodec(..), + NewlineMode(..), Newline(..), nativeNewline, + universalNewlineMode, noNewlineTranslation, nativeNewlineMode + ) where + +#undef DEBUG + +import GHC.Base +import GHC.MVar +import GHC.IO +import GHC.IO.Buffer +import GHC.IO.BufferedIO +import GHC.IO.Encoding.Types +import GHC.IORef +import Data.Maybe +import GHC.Show +import GHC.Read +import GHC.Word +import GHC.IO.Device +import Data.Typeable + +-- --------------------------------------------------------------------------- +-- Handle type + +-- A Handle is represented by (a reference to) a record +-- containing the state of the I/O port/device. We record +-- the following pieces of info: + +-- * type (read,write,closed etc.) +-- * the underlying file descriptor +-- * buffering mode +-- * buffer, and spare buffers +-- * user-friendly name (usually the +-- FilePath used when IO.openFile was called) + +-- Note: when a Handle is garbage collected, we want to flush its buffer +-- and close the OS file handle, so as to free up a (precious) resource. + +-- | Haskell defines operations to read and write characters from and to files, +-- represented by values of type @Handle@. Each value of this type is a +-- /handle/: a record used by the Haskell run-time system to /manage/ I\/O +-- with file system objects. A handle has at least the following properties: +-- +-- * whether it manages input or output or both; +-- +-- * whether it is /open/, /closed/ or /semi-closed/; +-- +-- * whether the object is seekable; +-- +-- * whether buffering is disabled, or enabled on a line or block basis; +-- +-- * a buffer (whose length may be zero). +-- +-- Most handles will also have a current I\/O position indicating where the next +-- input or output operation will occur. A handle is /readable/ if it +-- manages only input or both input and output; likewise, it is /writable/ if +-- it manages only output or both input and output. A handle is /open/ when +-- first allocated. +-- Once it is closed it can no longer be used for either input or output, +-- though an implementation cannot re-use its storage while references +-- remain to it. Handles are in the 'Show' and 'Eq' classes. The string +-- produced by showing a handle is system dependent; it should include +-- enough information to identify the handle for debugging. A handle is +-- equal according to '==' only to itself; no attempt +-- is made to compare the internal state of different handles for equality. +-- +-- GHC note: a 'Handle' will be automatically closed when the garbage +-- collector detects that it has become unreferenced by the program. +-- However, relying on this behaviour is not generally recommended: +-- the garbage collector is unpredictable. If possible, use explicit +-- an explicit 'hClose' to close 'Handle's when they are no longer +-- required. GHC does not currently attempt to free up file +-- descriptors when they have run out, it is your responsibility to +-- ensure that this doesn't happen. + +data Handle + = FileHandle -- A normal handle to a file + FilePath -- the file (used for error messages + -- only) + !(MVar Handle__) + + | DuplexHandle -- A handle to a read/write stream + FilePath -- file for a FIFO, otherwise some + -- descriptive string (used for error + -- messages only) + !(MVar Handle__) -- The read side + !(MVar Handle__) -- The write side + + deriving Typeable + +-- NOTES: +-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be +-- seekable. + +instance Eq Handle where + (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2 + (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2 + _ == _ = False + +data Handle__ + = forall dev enc_state dec_state . (IODevice dev, BufferedIO dev, Typeable dev) => + Handle__ { + haDevice :: !dev, + haType :: HandleType, -- type (read/write/append etc.) + haByteBuffer :: !(IORef (Buffer Word8)), + haBufferMode :: BufferMode, + haLastDecode :: !(IORef (dec_state, Buffer Word8)), + haCharBuffer :: !(IORef (Buffer CharBufElem)), -- the current buffer + haBuffers :: !(IORef (BufferList CharBufElem)), -- spare buffers + haEncoder :: Maybe (TextEncoder enc_state), + haDecoder :: Maybe (TextDecoder dec_state), + haCodec :: Maybe TextEncoding, + haInputNL :: Newline, + haOutputNL :: Newline, + haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a + -- duplex handle. + } + deriving Typeable + +-- we keep a few spare buffers around in a handle to avoid allocating +-- a new one for each hPutStr. These buffers are *guaranteed* to be the +-- same size as the main buffer. +data BufferList e + = BufferListNil + | BufferListCons (RawBuffer e) (BufferList e) + +-- Internally, we classify handles as being one +-- of the following: + +data HandleType + = ClosedHandle + | SemiClosedHandle + | ReadHandle + | WriteHandle + | AppendHandle + | ReadWriteHandle + +isReadableHandleType :: HandleType -> Bool +isReadableHandleType ReadHandle = True +isReadableHandleType ReadWriteHandle = True +isReadableHandleType _ = False + +isWritableHandleType :: HandleType -> Bool +isWritableHandleType AppendHandle = True +isWritableHandleType WriteHandle = True +isWritableHandleType ReadWriteHandle = True +isWritableHandleType _ = False + +isReadWriteHandleType :: HandleType -> Bool +isReadWriteHandleType ReadWriteHandle{} = True +isReadWriteHandleType _ = False + +-- INVARIANTS on Handles: +-- +-- * A handle *always* has a buffer, even if it is only 1 character long +-- (an unbuffered handle needs a 1 character buffer in order to support +-- hLookAhead and hIsEOF). +-- * In a read Handle, the byte buffer is always empty (we decode when reading) +-- * In a wriite Handle, the Char buffer is always empty (we encode when writing) +-- +checkHandleInvariants :: Handle__ -> IO () +#ifdef DEBUG +checkHandleInvariants h_ = do + bbuf <- readIORef (haByteBuffer h_) + checkBuffer bbuf + cbuf <- readIORef (haCharBuffer h_) + checkBuffer cbuf +#else +checkHandleInvariants _ = return () +#endif + +-- --------------------------------------------------------------------------- +-- Buffering modes + +-- | Three kinds of buffering are supported: line-buffering, +-- block-buffering or no-buffering. These modes have the following +-- effects. For output, items are written out, or /flushed/, +-- from the internal buffer according to the buffer mode: +-- +-- * /line-buffering/: the entire output buffer is flushed +-- whenever a newline is output, the buffer overflows, +-- a 'System.IO.hFlush' is issued, or the handle is closed. +-- +-- * /block-buffering/: the entire buffer is written out whenever it +-- overflows, a 'System.IO.hFlush' is issued, or the handle is closed. +-- +-- * /no-buffering/: output is written immediately, and never stored +-- in the buffer. +-- +-- An implementation is free to flush the buffer more frequently, +-- but not less frequently, than specified above. +-- The output buffer is emptied as soon as it has been written out. +-- +-- Similarly, input occurs according to the buffer mode for the handle: +-- +-- * /line-buffering/: when the buffer for the handle is not empty, +-- the next item is obtained from the buffer; otherwise, when the +-- buffer is empty, characters up to and including the next newline +-- character are read into the buffer. No characters are available +-- until the newline character is available or the buffer is full. +-- +-- * /block-buffering/: when the buffer for the handle becomes empty, +-- the next block of data is read into the buffer. +-- +-- * /no-buffering/: the next input item is read and returned. +-- The 'System.IO.hLookAhead' operation implies that even a no-buffered +-- handle may require a one-character buffer. +-- +-- The default buffering mode when a handle is opened is +-- implementation-dependent and may depend on the file system object +-- which is attached to that handle. +-- For most implementations, physical files will normally be block-buffered +-- and terminals will normally be line-buffered. + +data BufferMode + = NoBuffering -- ^ buffering is disabled if possible. + | LineBuffering + -- ^ line-buffering should be enabled if possible. + | BlockBuffering (Maybe Int) + -- ^ block-buffering should be enabled if possible. + -- The size of the buffer is @n@ items if the argument + -- is 'Just' @n@ and is otherwise implementation-dependent. + deriving (Eq, Ord, Read, Show) + +{- +[note Buffering Implementation] + +Each Handle has two buffers: a byte buffer (haByteBuffer) and a Char +buffer (haCharBuffer). + +[note Buffered Reading] + +For read Handles, bytes are read into the byte buffer, and immediately +decoded into the Char buffer (see +GHC.IO.Handle.Internals.readTextDevice). The only way there might be +some data left in the byte buffer is if there is a partial multi-byte +character sequence that cannot be decoded into a full character. + +Note that the buffering mode (haBufferMode) makes no difference when +reading data into a Handle. When reading, we can always just read all +the data there is available without blocking, decode it into the Char +buffer, and then provide it immediately to the caller. + +[note Buffered Writing] + +Characters are written into the Char buffer by e.g. hPutStr. When the +buffer is full, we call writeTextDevice, which encodes the Char buffer +into the byte buffer, and then immediately writes it all out to the +underlying device. The Char buffer will always be empty afterward. +This might require multiple decoding/writing cycles. + +[note Buffer Sizing] + +Since the buffer mode makes no difference when reading, we can just +use the default buffer size for both the byte and the Char buffer. +Ineed, we must have room for at least one Char in the Char buffer, +because we have to implement hLookAhead, which requires caching a Char +in the Handle. Furthermore, when doing newline translation, we need +room for at least two Chars in the read buffer, so we can spot the +\r\n sequence. + +For writing, however, when the buffer mode is NoBuffering, we use a +1-element Char buffer to force flushing of the buffer after each Char +is read. + +[note Buffer Flushing] + +** Flushing the Char buffer + +We must be able to flush the Char buffer, in order to implement +hSetEncoding, and things like hGetBuf which want to read raw bytes. + +Flushing the Char buffer on a write Handle is easy: just call +writeTextDevice to encode and write the date. + +Flushing the Char buffer on a read Handle involves rewinding the byte +buffer to the point representing the next Char in the Char buffer. +This is done by + + - remembering the state of the byte buffer *before* the last decode + + - re-decoding the bytes that represent the chars already read from the + Char buffer. This gives us the point in the byte buffer that + represents the *next* Char to be read. + +In order for this to work, after readTextHandle we must NOT MODIFY THE +CONTENTS OF THE BYTE OR CHAR BUFFERS, except to remove characters from +the Char buffer. + +** Flushing the byte buffer + +The byte buffer can be flushed if the Char buffer has already been +flushed (see above). For a read Handle, flushing the byte buffer +means seeking the device back by the number of bytes in the buffer, +and hence it is only possible on a seekable Handle. + +-} + +-- --------------------------------------------------------------------------- +-- Newline translation + +-- | The representation of a newline in the external file or stream. +data Newline = LF -- ^ '\n' + | CRLF -- ^ '\r\n' + deriving Eq + +-- | Specifies the translation, if any, of newline characters between +-- internal Strings and the external file or stream. Haskell Strings +-- are assumed to represent newlines with the '\n' character; the +-- newline mode specifies how to translate '\n' on output, and what to +-- translate into '\n' on input. +data NewlineMode + = NewlineMode { inputNL :: Newline, + -- ^ the representation of newlines on input + outputNL :: Newline + -- ^ the representation of newlines on output + } + deriving Eq + +-- | The native newline representation for the current platform: 'LF' +-- on Unix systems, 'CRLF' on Windows. +nativeNewline :: Newline +#ifdef mingw32_HOST_OS +nativeNewline = CRLF +#else +nativeNewline = LF +#endif + +-- | Map '\r\n' into '\n' on input, and '\n' to the native newline +-- represetnation on output. This mode can be used on any platform, and +-- works with text files using any newline convention. The downside is +-- that @readFile >>= writeFile@ might yield a different file. +-- +-- > universalNewlineMode = NewlineMode { inputNL = CRLF, +-- > outputNL = nativeNewline } +-- +universalNewlineMode :: NewlineMode +universalNewlineMode = NewlineMode { inputNL = CRLF, + outputNL = nativeNewline } + +-- | Use the native newline representation on both input and output +-- +-- > nativeNewlineMode = NewlineMode { inputNL = nativeNewline +-- > outputNL = nativeNewline } +-- +nativeNewlineMode :: NewlineMode +nativeNewlineMode = NewlineMode { inputNL = nativeNewline, + outputNL = nativeNewline } + +-- | Do no newline translation at all. +-- +-- > noNewlineTranslation = NewlineMode { inputNL = LF, outputNL = LF } +-- +noNewlineTranslation :: NewlineMode +noNewlineTranslation = NewlineMode { inputNL = LF, outputNL = LF } + +-- --------------------------------------------------------------------------- +-- Show instance for Handles + +-- handle types are 'show'n when printing error msgs, so +-- we provide a more user-friendly Show instance for it +-- than the derived one. + +instance Show HandleType where + showsPrec _ t = + case t of + ClosedHandle -> showString "closed" + SemiClosedHandle -> showString "semi-closed" + ReadHandle -> showString "readable" + WriteHandle -> showString "writable" + AppendHandle -> showString "writable (append)" + ReadWriteHandle -> showString "read-writable" + +instance Show Handle where + showsPrec _ (FileHandle file _) = showHandle file + showsPrec _ (DuplexHandle file _ _) = showHandle file + +showHandle :: FilePath -> String -> String +showHandle file = showString "{handle: " . showString file . showString "}" diff --git a/lib/base/src/GHC/IO/IOMode.hs b/lib/base/src/GHC/IO/IOMode.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IO/IOMode.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.IOMode +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- The IOMode type +-- +----------------------------------------------------------------------------- + +module GHC.IO.IOMode (IOMode(..)) where + +import GHC.Base +import GHC.Show +import GHC.Read +import GHC.Arr +import GHC.Enum + +data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode + deriving (Eq, Ord, Ix, Enum, Read, Show) diff --git a/lib/base/src/GHC/IOArray.hs b/lib/base/src/GHC/IOArray.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IOArray.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IOArray +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IOArray type +-- +----------------------------------------------------------------------------- + +module GHC.IOArray ( + IOArray(..), + newIOArray, unsafeReadIOArray, unsafeWriteIOArray, + readIOArray, writeIOArray, + boundsIOArray + ) where + +import GHC.Base +import GHC.IO +import GHC.Arr + +-- --------------------------------------------------------------------------- +-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. +-- The type arguments are as follows: +-- +-- * @i@: the index type of the array (should be an instance of 'Ix') +-- +-- * @e@: the element type of the array. +-- +-- + +newtype IOArray i e = IOArray (STArray RealWorld i e) + +-- explicit instance because Haddock can't figure out a derived one +instance Eq (IOArray i e) where + IOArray x == IOArray y = x == y + +-- |Build a new 'IOArray' +newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e) +{-# INLINE newIOArray #-} +newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)} + +-- | Read a value from an 'IOArray' +unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e +{-# INLINE unsafeReadIOArray #-} +unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i) + +-- | Write a new value into an 'IOArray' +unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO () +{-# INLINE unsafeWriteIOArray #-} +unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e) + +-- | Read a value from an 'IOArray' +readIOArray :: Ix i => IOArray i e -> i -> IO e +readIOArray (IOArray marr) i = stToIO (readSTArray marr i) + +-- | Write a new value into an 'IOArray' +writeIOArray :: Ix i => IOArray i e -> i -> e -> IO () +writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) + +{-# INLINE boundsIOArray #-} +boundsIOArray :: IOArray i e -> (i,i) +boundsIOArray (IOArray marr) = boundsSTArray marr diff --git a/lib/base/src/GHC/IOBase.hs b/lib/base/src/GHC/IOBase.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IOBase.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IOBase +-- Copyright : (c) The University of Glasgow 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Backwards-compatibility interface +-- +----------------------------------------------------------------------------- + + +module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} ( + IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- To and from from ST + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, + + -- References + IORef(..), newIORef, readIORef, writeIORef, + IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray, + MVar(..), + + -- Handles, file descriptors, + FilePath, + Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, + isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle, + + -- Buffers + -- Buffer(..), RawBuffer, BufferState(..), + BufferList(..), BufferMode(..), + --bufferIsWritable, bufferEmpty, bufferFull, + + -- Exceptions + Exception(..), ArithException(..), AsyncException(..), ArrayException(..), + stackOverflow, heapOverflow, ioException, + IOError, IOException(..), IOErrorType(..), ioError, userError, + ExitCode(..), + throwIO, block, unblock, blocked, catchAny, catchException, + evaluate, + ErrorCall(..), AssertionFailed(..), assertError, untangle, + BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), + blockedOnDeadMVar, blockedIndefinitely + ) where + +import GHC.Base +import GHC.Exception +import GHC.IO +import GHC.IO.Handle.Types +import GHC.IO.IOMode +import GHC.IO.Exception +import GHC.IOArray +import GHC.IORef +import GHC.MVar +import Foreign.C.Types +import GHC.Show +import Data.Typeable + +type FD = CInt + +-- Backwards compat: this was renamed to BlockedIndefinitelyOnMVar +data BlockedOnDeadMVar = BlockedOnDeadMVar + deriving Typeable + +instance Exception BlockedOnDeadMVar + +instance Show BlockedOnDeadMVar where + showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" + +blockedOnDeadMVar :: SomeException -- for the RTS +blockedOnDeadMVar = toException BlockedOnDeadMVar + + +-- Backwards compat: this was renamed to BlockedIndefinitelyOnSTM +data BlockedIndefinitely = BlockedIndefinitely + deriving Typeable + +instance Exception BlockedIndefinitely + +instance Show BlockedIndefinitely where + showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" + +blockedIndefinitely :: SomeException -- for the RTS +blockedIndefinitely = toException BlockedIndefinitely diff --git a/lib/base/src/GHC/IOBase.lhs b/lib/base/src/GHC/IOBase.lhs deleted file mode 100644 --- a/lib/base/src/GHC/IOBase.lhs +++ /dev/null @@ -1,1046 +0,0 @@ -\begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : GHC.IOBase --- Copyright : (c) The University of Glasgow 1994-2002 --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Definitions for the 'IO' monad and its friends. --- ------------------------------------------------------------------------------ - --- #hide -module GHC.IOBase( - IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, - unsafePerformIO, unsafeInterleaveIO, - unsafeDupablePerformIO, unsafeDupableInterleaveIO, - noDuplicate, - - -- To and from from ST - stToIO, ioToST, unsafeIOToST, unsafeSTToIO, - - -- References - IORef(..), newIORef, readIORef, writeIORef, - IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, - unsafeWriteIOArray, boundsIOArray, - MVar(..), - - -- Handles, file descriptors, - FilePath, - Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, - isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle, - - -- Buffers - Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..), - bufferIsWritable, bufferEmpty, bufferFull, - - -- Exceptions - Exception(..), {-ArithException(..),-} AsyncException(..), ArrayException(..), - --stackOverflow, heapOverflow, - ioException, - IOError, IOException(..), IOErrorType(..), ioError, userError, - ExitCode(..), - throwIO, block, unblock, blocked, catchAny, catchException, - evaluate, - {-ErrorCall(..), -}AssertionFailed(..), assertError, untangle, - BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), - --blockedOnDeadMVar, blockedIndefinitely - ) where - -import GHC.ST -import GHC.Arr -- to derive Ix class -import GHC.Enum -- to derive Enum class -import GHC.STRef -import GHC.Base --- import GHC.Num -- To get fromInteger etc, needed because of -XNoImplicitPrelude -import Data.Maybe ( Maybe(..) ) -import GHC.Show -import GHC.List -import GHC.Read -import Foreign.C.Types (CInt) -import GHC.Exception - -#ifndef __HADDOCK__ -import {-# SOURCE #-} Data.Typeable ( Typeable ) -#endif - --- --------------------------------------------------------------------------- --- The IO Monad - -{- -The IO Monad is just an instance of the ST monad, where the state is -the real world. We use the exception mechanism (in GHC.Exception) to -implement IO exceptions. - -NOTE: The IO representation is deeply wired in to various parts of the -system. The following list may or may not be exhaustive: - -Compiler - types of various primitives in PrimOp.lhs - -RTS - forceIO (StgMiscClosures.hc) - - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast - (Exceptions.hc) - - raiseAsync (Schedule.c) - -Prelude - GHC.IOBase.lhs, and several other places including - GHC.Exception.lhs. - -Libraries - parts of hslibs/lang. - ---SDM --} - -{-| -A value of type @'IO' a@ is a computation which, when performed, -does some I\/O before returning a value of type @a@. - -There is really only one way to \"perform\" an I\/O action: bind it to -@Main.main@ in your program. When your program is run, the I\/O will -be performed. It isn't possible to perform I\/O from an arbitrary -function, unless that function is itself in the 'IO' monad and called -at some point, directly or indirectly, from @Main.main@. - -'IO' is a monad, so 'IO' actions can be combined using either the do-notation -or the '>>' and '>>=' operations from the 'Monad' class. --} -newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) - -unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) -unIO (IO a) = a - -instance Functor IO where - fmap f x = x >>= (return . f) - -instance Monad IO where - {-# INLINE return #-} - {-# INLINE (>>) #-} - {-# INLINE (>>=) #-} - m >> k = m >>= \ _ -> k - return x = returnIO x - - m >>= k = bindIO m k - fail s = failIO s - -failIO :: String -> IO a -failIO s = ioError (userError s) - -liftIO :: IO a -> State# RealWorld -> STret RealWorld a -liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r - -bindIO :: IO a -> (a -> IO b) -> IO b -bindIO (IO m) k = IO ( \ s -> - case m s of - (# new_s, a #) -> unIO (k a) new_s - ) - -thenIO :: IO a -> IO b -> IO b -thenIO (IO m) k = IO ( \ s -> - case m s of - (# new_s, _ #) -> unIO k new_s - ) - -returnIO :: a -> IO a -returnIO x = IO (\ s -> (# s, x #)) - --- --------------------------------------------------------------------------- --- Coercions between IO and ST - --- | A monad transformer embedding strict state transformers in the 'IO' --- monad. The 'RealWorld' parameter indicates that the internal state --- used by the 'ST' computation is a special one supplied by the 'IO' --- monad, and thus distinct from those used by invocations of 'runST'. -stToIO :: ST RealWorld a -> IO a -stToIO (ST m) = IO m - -ioToST :: IO a -> ST RealWorld a -ioToST (IO m) = (ST m) - --- This relies on IO and ST having the same representation modulo the --- constraint on the type of the state --- -unsafeIOToST :: IO a -> ST s a -unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s - -unsafeSTToIO :: ST s a -> IO a -unsafeSTToIO (ST m) = IO (unsafeCoerce# m) - --- --------------------------------------------------------------------------- --- Unsafe IO operations - -{-| -This is the \"back door\" into the 'IO' monad, allowing -'IO' computation to be performed at any time. For -this to be safe, the 'IO' computation should be -free of side effects and independent of its environment. - -If the I\/O computation wrapped in 'unsafePerformIO' -performs side effects, then the relative order in which those side -effects take place (relative to the main I\/O trunk, or other calls to -'unsafePerformIO') is indeterminate. You have to be careful when -writing and compiling modules that use 'unsafePerformIO': - - * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ - that calls 'unsafePerformIO'. If the call is inlined, - the I\/O may be performed more than once. - - * Use the compiler flag @-fno-cse@ to prevent common sub-expression - elimination being performed on the module, which might combine - two side effects that were meant to be separate. A good example - is using multiple global variables (like @test@ in the example below). - - * Make sure that the either you switch off let-floating, or that the - call to 'unsafePerformIO' cannot float outside a lambda. For example, - if you say: - @ - f x = unsafePerformIO (newIORef []) - @ - you may get only one reference cell shared between all calls to @f@. - Better would be - @ - f x = unsafePerformIO (newIORef [x]) - @ - because now it can't float outside the lambda. - -It is less well known that -'unsafePerformIO' is not type safe. For example: - -> test :: IORef [a] -> test = unsafePerformIO $ newIORef [] -> -> main = do -> writeIORef test [42] -> bang <- readIORef test -> print (bang :: [Char]) - -This program will core dump. This problem with polymorphic references -is well known in the ML community, and does not arise with normal -monadic use of references. There is no easy way to make it impossible -once you use 'unsafePerformIO'. Indeed, it is -possible to write @coerce :: a -> b@ with the -help of 'unsafePerformIO'. So be careful! --} -unsafePerformIO :: IO a -> a -unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) - -{-| -This version of 'unsafePerformIO' is slightly more efficient, -because it omits the check that the IO is only being performed by a -single thread. Hence, when you write 'unsafeDupablePerformIO', -there is a possibility that the IO action may be performed multiple -times (on a multiprocessor), and you should therefore ensure that -it gives the same results each time. --} -{-# NOINLINE unsafeDupablePerformIO #-} -unsafeDupablePerformIO :: IO a -> a -unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) - --- Why do we NOINLINE unsafeDupablePerformIO? See the comment with --- GHC.ST.runST. Essentially the issue is that the IO computation --- inside unsafePerformIO must be atomic: it must either all run, or --- not at all. If we let the compiler see the application of the IO --- to realWorld#, it might float out part of the IO. - --- Why is there a call to 'lazy' in unsafeDupablePerformIO? --- If we don't have it, the demand analyser discovers the following strictness --- for unsafeDupablePerformIO: C(U(AV)) --- But then consider --- unsafeDupablePerformIO (\s -> let r = f x in --- case writeIORef v r s of (# s1, _ #) -> --- (# s1, r #) --- The strictness analyser will find that the binding for r is strict, --- (becuase of uPIO's strictness sig), and so it'll evaluate it before --- doing the writeIORef. This actually makes tests/lib/should_run/memo002 --- get a deadlock! --- --- Solution: don't expose the strictness of unsafeDupablePerformIO, --- by hiding it with 'lazy' - -{-| -'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily. -When passed a value of type @IO a@, the 'IO' will only be performed -when the value of the @a@ is demanded. This is used to implement lazy -file reading, see 'System.IO.hGetContents'. --} -{-# INLINE unsafeInterleaveIO #-} -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) - --- We believe that INLINE on unsafeInterleaveIO is safe, because the --- state from this IO thread is passed explicitly to the interleaved --- IO, so it cannot be floated out and shared. - -{-# INLINE unsafeDupableInterleaveIO #-} -unsafeDupableInterleaveIO :: IO a -> IO a -unsafeDupableInterleaveIO (IO m) - = IO ( \ s -> let - r = case m s of (# _, res #) -> res - in - (# s, r #)) - -{-| -Ensures that the suspensions under evaluation by the current thread -are unique; that is, the current thread is not evaluating anything -that is also under evaluation by another thread that has also executed -'noDuplicate'. - -This operation is used in the definition of 'unsafePerformIO' to -prevent the IO action from being executed multiple times, which is usually -undesirable. --} -noDuplicate :: IO () -noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) - --- --------------------------------------------------------------------------- --- Handle type - -data MVar a = MVar (MVar# RealWorld a) -{- ^ -An 'MVar' (pronounced \"em-var\") is a synchronising variable, used -for communication between concurrent threads. It can be thought of -as a a box, which may be empty or full. --} - --- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module -instance Eq (MVar a) where - (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# - --- A Handle is represented by (a reference to) a record --- containing the state of the I/O port/device. We record --- the following pieces of info: - --- * type (read,write,closed etc.) --- * the underlying file descriptor --- * buffering mode --- * buffer, and spare buffers --- * user-friendly name (usually the --- FilePath used when IO.openFile was called) - --- Note: when a Handle is garbage collected, we want to flush its buffer --- and close the OS file handle, so as to free up a (precious) resource. - --- | Haskell defines operations to read and write characters from and to files, --- represented by values of type @Handle@. Each value of this type is a --- /handle/: a record used by the Haskell run-time system to /manage/ I\/O --- with file system objects. A handle has at least the following properties: --- --- * whether it manages input or output or both; --- --- * whether it is /open/, /closed/ or /semi-closed/; --- --- * whether the object is seekable; --- --- * whether buffering is disabled, or enabled on a line or block basis; --- --- * a buffer (whose length may be zero). --- --- Most handles will also have a current I\/O position indicating where the next --- input or output operation will occur. A handle is /readable/ if it --- manages only input or both input and output; likewise, it is /writable/ if --- it manages only output or both input and output. A handle is /open/ when --- first allocated. --- Once it is closed it can no longer be used for either input or output, --- though an implementation cannot re-use its storage while references --- remain to it. Handles are in the 'Show' and 'Eq' classes. The string --- produced by showing a handle is system dependent; it should include --- enough information to identify the handle for debugging. A handle is --- equal according to '==' only to itself; no attempt --- is made to compare the internal state of different handles for equality. --- --- GHC note: a 'Handle' will be automatically closed when the garbage --- collector detects that it has become unreferenced by the program. --- However, relying on this behaviour is not generally recommended: --- the garbage collector is unpredictable. If possible, use explicit --- an explicit 'hClose' to close 'Handle's when they are no longer --- required. GHC does not currently attempt to free up file --- descriptors when they have run out, it is your responsibility to --- ensure that this doesn't happen. - -data Handle - = FileHandle -- A normal handle to a file - FilePath -- the file (invariant) - !(MVar Handle__) - - | DuplexHandle -- A handle to a read/write stream - FilePath -- file for a FIFO, otherwise some - -- descriptive string. - !(MVar Handle__) -- The read side - !(MVar Handle__) -- The write side - --- NOTES: --- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be --- seekable. - -instance Eq Handle where - (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2 - (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2 - _ == _ = False - -type FD = CInt - -data Handle__ - = Handle__ { - haFD :: !FD, -- file descriptor - haType :: HandleType, -- type (read/write/append etc.) - haIsBin :: Bool, -- binary mode? - haIsStream :: Bool, -- Windows : is this a socket? - -- Unix : is O_NONBLOCK set? - haBufferMode :: BufferMode, -- buffer contains read/write data? - haBuffer :: !(IORef Buffer), -- the current buffer - haBuffers :: !(IORef BufferList), -- spare buffers - haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a - -- duplex handle. - } - --- --------------------------------------------------------------------------- --- Buffers - --- The buffer is represented by a mutable variable containing a --- record, where the record contains the raw buffer and the start/end --- points of the filled portion. We use a mutable variable so that --- the common operation of writing (or reading) some data from (to) --- the buffer doesn't need to modify, and hence copy, the handle --- itself, it just updates the buffer. - --- There will be some allocation involved in a simple hPutChar in --- order to create the new Buffer structure (below), but this is --- relatively small, and this only has to be done once per write --- operation. - --- The buffer contains its size - we could also get the size by --- calling sizeOfMutableByteArray# on the raw buffer, but that tends --- to be rounded up to the nearest Word. - -type RawBuffer = MutableByteArray# RealWorld - --- INVARIANTS on a Buffer: --- --- * A handle *always* has a buffer, even if it is only 1 character long --- (an unbuffered handle needs a 1 character buffer in order to support --- hLookAhead and hIsEOF). --- * r <= w --- * if r == w, then r == 0 && w == 0 --- * if state == WriteBuffer, then r == 0 --- * a write buffer is never full. If an operation --- fills up the buffer, it will always flush it before --- returning. --- * a read buffer may be full as a result of hLookAhead. In normal --- operation, a read buffer always has at least one character of space. - -data Buffer - = Buffer { - bufBuf :: RawBuffer, - bufRPtr :: !Int, - bufWPtr :: !Int, - bufSize :: !Int, - bufState :: BufferState - } - -data BufferState = ReadBuffer | WriteBuffer deriving (Eq) - --- we keep a few spare buffers around in a handle to avoid allocating --- a new one for each hPutStr. These buffers are *guaranteed* to be the --- same size as the main buffer. -data BufferList - = BufferListNil - | BufferListCons RawBuffer BufferList - - -bufferIsWritable :: Buffer -> Bool -bufferIsWritable Buffer{ bufState=WriteBuffer } = True -bufferIsWritable _other = False - -bufferEmpty :: Buffer -> Bool -bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w - --- only makes sense for a write buffer -bufferFull :: Buffer -> Bool -bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b - --- Internally, we classify handles as being one --- of the following: - -data HandleType - = ClosedHandle - | SemiClosedHandle - | ReadHandle - | WriteHandle - | AppendHandle - | ReadWriteHandle - -isReadableHandleType :: HandleType -> Bool -isReadableHandleType ReadHandle = True -isReadableHandleType ReadWriteHandle = True -isReadableHandleType _ = False - -isWritableHandleType :: HandleType -> Bool -isWritableHandleType AppendHandle = True -isWritableHandleType WriteHandle = True -isWritableHandleType ReadWriteHandle = True -isWritableHandleType _ = False - -isReadWriteHandleType :: HandleType -> Bool -isReadWriteHandleType ReadWriteHandle{} = True -isReadWriteHandleType _ = False - --- | File and directory names are values of type 'String', whose precise --- meaning is operating system dependent. Files can be opened, yielding a --- handle which can then be used to operate on the contents of that file. - -type FilePath = String - --- --------------------------------------------------------------------------- --- Buffering modes - --- | Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. These modes have the following --- effects. For output, items are written out, or /flushed/, --- from the internal buffer according to the buffer mode: --- --- * /line-buffering/: the entire output buffer is flushed --- whenever a newline is output, the buffer overflows, --- a 'System.IO.hFlush' is issued, or the handle is closed. --- --- * /block-buffering/: the entire buffer is written out whenever it --- overflows, a 'System.IO.hFlush' is issued, or the handle is closed. --- --- * /no-buffering/: output is written immediately, and never stored --- in the buffer. --- --- An implementation is free to flush the buffer more frequently, --- but not less frequently, than specified above. --- The output buffer is emptied as soon as it has been written out. --- --- Similarly, input occurs according to the buffer mode for the handle: --- --- * /line-buffering/: when the buffer for the handle is not empty, --- the next item is obtained from the buffer; otherwise, when the --- buffer is empty, characters up to and including the next newline --- character are read into the buffer. No characters are available --- until the newline character is available or the buffer is full. --- --- * /block-buffering/: when the buffer for the handle becomes empty, --- the next block of data is read into the buffer. --- --- * /no-buffering/: the next input item is read and returned. --- The 'System.IO.hLookAhead' operation implies that even a no-buffered --- handle may require a one-character buffer. --- --- The default buffering mode when a handle is opened is --- implementation-dependent and may depend on the file system object --- which is attached to that handle. --- For most implementations, physical files will normally be block-buffered --- and terminals will normally be line-buffered. - -data BufferMode - = NoBuffering -- ^ buffering is disabled if possible. - | LineBuffering - -- ^ line-buffering should be enabled if possible. - | BlockBuffering (Maybe Int) - -- ^ block-buffering should be enabled if possible. - -- The size of the buffer is @n@ items if the argument - -- is 'Just' @n@ and is otherwise implementation-dependent. --- deriving (Eq, Ord, Read, Show) - deriving (Eq, Ord, Show) - --- --------------------------------------------------------------------------- --- IORefs - --- |A mutable variable in the 'IO' monad -newtype IORef a = IORef (STRef RealWorld a) - --- explicit instance because Haddock can't figure out a derived one -instance Eq (IORef a) where - IORef x == IORef y = x == y - --- |Build a new 'IORef' -newIORef :: a -> IO (IORef a) -newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) - --- |Read the value of an 'IORef' -readIORef :: IORef a -> IO a -readIORef (IORef var) = stToIO (readSTRef var) - --- |Write a new value into an 'IORef' -writeIORef :: IORef a -> a -> IO () -writeIORef (IORef var) v = stToIO (writeSTRef var v) - --- --------------------------------------------------------------------------- --- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. --- The type arguments are as follows: --- --- * @i@: the index type of the array (should be an instance of 'Ix') --- --- * @e@: the element type of the array. --- --- - -newtype IOArray i e = IOArray (STArray RealWorld i e) - --- explicit instance because Haddock can't figure out a derived one -instance Eq (IOArray i e) where - IOArray x == IOArray y = x == y - --- |Build a new 'IOArray' -newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e) -{-# INLINE newIOArray #-} -newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)} - --- | Read a value from an 'IOArray' -unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e -{-# INLINE unsafeReadIOArray #-} -unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i) - --- | Write a new value into an 'IOArray' -unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO () -{-# INLINE unsafeWriteIOArray #-} -unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e) - --- | Read a value from an 'IOArray' -readIOArray :: Ix i => IOArray i e -> i -> IO e -readIOArray (IOArray marr) i = stToIO (readSTArray marr i) - --- | Write a new value into an 'IOArray' -writeIOArray :: Ix i => IOArray i e -> i -> e -> IO () -writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) - -{-# INLINE boundsIOArray #-} -boundsIOArray :: IOArray i e -> (i,i) -boundsIOArray (IOArray marr) = boundsSTArray marr - --- --------------------------------------------------------------------------- --- Show instance for Handles - --- handle types are 'show'n when printing error msgs, so --- we provide a more user-friendly Show instance for it --- than the derived one. - -instance Show HandleType where - showsPrec _ t = - case t of - ClosedHandle -> showString "closed" - SemiClosedHandle -> showString "semi-closed" - ReadHandle -> showString "readable" - WriteHandle -> showString "writable" - AppendHandle -> showString "writable (append)" - ReadWriteHandle -> showString "read-writable" - -instance Show Handle where - showsPrec _ (FileHandle file _) = showHandle file - showsPrec _ (DuplexHandle file _ _) = showHandle file - -showHandle :: FilePath -> String -> String -showHandle file = showString "{handle: " . showString file . showString "}" - --- ------------------------------------------------------------------------ --- Exception datatypes and operations - --- |The thread is blocked on an @MVar@, but there are no other references --- to the @MVar@ so it can't ever continue. -data BlockedOnDeadMVar = BlockedOnDeadMVar - deriving Typeable - -instance Exception BlockedOnDeadMVar - -instance Show BlockedOnDeadMVar where - showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" - ---blockedOnDeadMVar :: SomeException -- for the RTS ---blockedOnDeadMVar = toException BlockedOnDeadMVar - ------ - --- |The thread is awiting to retry an STM transaction, but there are no --- other references to any @TVar@s involved, so it can't ever continue. -data BlockedIndefinitely = BlockedIndefinitely - deriving Typeable - -instance Exception BlockedIndefinitely - -instance Show BlockedIndefinitely where - showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" - ---blockedIndefinitely :: SomeException -- for the RTS ---blockedIndefinitely = toException BlockedIndefinitely - ------ - --- |There are no runnable threads, so the program is deadlocked. --- The @Deadlock@ exception is raised in the main thread only. -data Deadlock = Deadlock - deriving Typeable - -instance Exception Deadlock - -instance Show Deadlock where - showsPrec _ Deadlock = showString "<>" - ------ - --- |Exceptions generated by 'assert'. The @String@ gives information --- about the source location of the assertion. -data AssertionFailed = AssertionFailed String - deriving Typeable - -instance Exception AssertionFailed - -instance Show AssertionFailed where - showsPrec _ (AssertionFailed err) = showString err - ------ - --- |Asynchronous exceptions. -data AsyncException - = StackOverflow - -- ^The current thread\'s stack exceeded its limit. - -- Since an exception has been raised, the thread\'s stack - -- will certainly be below its limit again, but the - -- programmer should take remedial action - -- immediately. - | HeapOverflow - -- ^The program\'s heap is reaching its limit, and - -- the program should take action to reduce the amount of - -- live data it has. Notes: - -- - -- * It is undefined which thread receives this exception. - -- - -- * GHC currently does not throw 'HeapOverflow' exceptions. - | ThreadKilled - -- ^This exception is raised by another thread - -- calling 'Control.Concurrent.killThread', or by the system - -- if it needs to terminate the thread for some - -- reason. - | UserInterrupt - -- ^This exception is raised by default in the main thread of - -- the program when the user requests to terminate the program - -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord, Typeable) - -instance Exception AsyncException - --- | Exceptions generated by array operations -data ArrayException - = IndexOutOfBounds String - -- ^An attempt was made to index an array outside - -- its declared bounds. - | UndefinedElement String - -- ^An attempt was made to evaluate an element of an - -- array that had not been initialized. - deriving (Eq, Ord, Typeable) - -instance Exception ArrayException - ---stackOverflow, heapOverflow :: SomeException -- for the RTS ---stackOverflow = toException StackOverflow ---heapOverflow = toException HeapOverflow - -instance Show AsyncException where - showsPrec _ StackOverflow = showString "stack overflow" - showsPrec _ HeapOverflow = showString "heap overflow" - showsPrec _ ThreadKilled = showString "thread killed" - showsPrec _ UserInterrupt = showString "user interrupt" - -instance Show ArrayException where - showsPrec _ (IndexOutOfBounds s) - = showString "array index out of range" - . (if not (null s) then showString ": " . showString s - else id) - showsPrec _ (UndefinedElement s) - = showString "undefined array element" - . (if not (null s) then showString ": " . showString s - else id) - --- ----------------------------------------------------------------------------- --- The ExitCode type - --- We need it here because it is used in ExitException in the --- Exception datatype (above). - -data ExitCode - = ExitSuccess -- ^ indicates successful termination; - | ExitFailure Int - -- ^ indicates program failure with an exit code. - -- The exact interpretation of the code is - -- operating-system dependent. In particular, some values - -- may be prohibited (e.g. 0 on a POSIX-compliant system). - deriving (Eq, Ord, Read, Show, Typeable) - -instance Exception ExitCode - -ioException :: IOException -> IO a -ioException err = throwIO err - --- | Raise an 'IOError' in the 'IO' monad. -ioError :: IOError -> IO a -ioError = ioException - --- --------------------------------------------------------------------------- --- IOError type - --- | The Haskell 98 type for exceptions in the 'IO' monad. --- Any I\/O operation may raise an 'IOError' instead of returning a result. --- For a more general type of exception, including also those that arise --- in pure code, see 'Control.Exception.Exception'. --- --- In Haskell 98, this is an opaque type. -type IOError = IOException - --- |Exceptions that occur in the @IO@ monad. --- An @IOException@ records a more specific error type, a descriptive --- string and maybe the handle that was used when the error was --- flagged. -data IOException - = IOError { - ioe_handle :: Maybe Handle, -- the handle used by the action flagging - -- the error. - ioe_type :: IOErrorType, -- what it was. - ioe_location :: String, -- location. - ioe_description :: String, -- error type specific information. - ioe_filename :: Maybe FilePath -- filename the error is related to. - } - deriving Typeable - -instance Exception IOException - -instance Eq IOException where - (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = - e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2 - --- | An abstract type that contains a value for each variant of 'IOError'. -data IOErrorType - -- Haskell 98: - = AlreadyExists - | NoSuchThing - | ResourceBusy - | ResourceExhausted - | EOF - | IllegalOperation - | PermissionDenied - | UserError - -- GHC only: - | UnsatisfiedConstraints - | SystemError - | ProtocolError - | OtherError - | InvalidArgument - | InappropriateType - | HardwareFault - | UnsupportedOperation - | TimeExpired - | ResourceVanished - | Interrupted - -instance Eq IOErrorType where - x == y = getTag x ==# getTag y - -instance Show IOErrorType where - showsPrec _ e = - showString $ - case e of - AlreadyExists -> "already exists" - NoSuchThing -> "does not exist" - ResourceBusy -> "resource busy" - ResourceExhausted -> "resource exhausted" - EOF -> "end of file" - IllegalOperation -> "illegal operation" - PermissionDenied -> "permission denied" - UserError -> "user error" - HardwareFault -> "hardware fault" - InappropriateType -> "inappropriate type" - Interrupted -> "interrupted" - InvalidArgument -> "invalid argument" - OtherError -> "failed" - ProtocolError -> "protocol error" - ResourceVanished -> "resource vanished" - SystemError -> "system error" - TimeExpired -> "timeout" - UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! - UnsupportedOperation -> "unsupported operation" - --- | Construct an 'IOError' value with a string describing the error. --- The 'fail' method of the 'IO' instance of the 'Monad' class raises a --- 'userError', thus: --- --- > instance Monad IO where --- > ... --- > fail s = ioError (userError s) --- -userError :: String -> IOError -userError str = IOError Nothing UserError "" str Nothing - --- --------------------------------------------------------------------------- --- Showing IOErrors - -instance Show IOException where - showsPrec p (IOError hdl iot loc s fn) = - (case fn of - Nothing -> case hdl of - Nothing -> id - Just h -> showsPrec p h . showString ": " - Just name -> showString name . showString ": ") . - (case loc of - "" -> id - _ -> showString loc . showString ": ") . - showsPrec p iot . - (case s of - "" -> id - _ -> showString " (" . showString s . showString ")") - --- ----------------------------------------------------------------------------- --- IOMode type - -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) -\end{code} - -%********************************************************* -%* * -\subsection{Primitive catch and throwIO} -%* * -%********************************************************* - -catchException used to handle the passing around of the state to the -action and the handler. This turned out to be a bad idea - it meant -that we had to wrap both arguments in thunks so they could be entered -as normal (remember IO returns an unboxed pair...). - -Now catch# has type - - catch# :: IO a -> (b -> IO a) -> IO a - -(well almost; the compiler doesn't know about the IO newtype so we -have to work around that in the definition of catchException below). - -\begin{code} - -catchException :: Exception e => IO a -> (e -> IO a) -> IO a -catchException io handler = io{- -catchException (IO io) handler = IO $ catch# io handler' - where handler' e = case fromException e of - Just e' -> unIO (handler e') - Nothing -> raise# e-} - -catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a -catchAny io handler = io{- -catchAny (IO io) handler = IO $ catch# io handler' - where handler' (SomeException e) = unIO (handler e)-} - --- | A variant of 'throw' that can only be used within the 'IO' monad. --- --- Although 'throwIO' has a type that is an instance of the type of 'throw', the --- two functions are subtly different: --- --- > throw e `seq` x ===> throw e --- > throwIO e `seq` x ===> x --- --- The first example will cause the exception @e@ to be raised, --- whereas the second one won\'t. In fact, 'throwIO' will only cause --- an exception to be raised when it is used within the 'IO' monad. --- The 'throwIO' variant should be used in preference to 'throw' to --- raise an exception within the 'IO' monad because it guarantees --- ordering with respect to other 'IO' operations, whereas 'throw' --- does not. -throwIO :: Exception e => e -> IO a -throwIO e = IO (raiseIO# (toException e)) - -\end{code} - - -%********************************************************* -%* * -\subsection{Controlling asynchronous exception delivery} -%* * -%********************************************************* - -\begin{code} --- | Applying 'block' to a computation will --- execute that computation with asynchronous exceptions --- /blocked/. That is, any thread which --- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be --- blocked until asynchronous exceptions are enabled again. There\'s --- no need to worry about re-enabling asynchronous exceptions; that is --- done automatically on exiting the scope of --- 'block'. --- --- Threads created by 'Control.Concurrent.forkIO' inherit the blocked --- state from the parent; that is, to start a thread in blocked mode, --- use @block $ forkIO ...@. This is particularly useful if you need to --- establish an exception handler in the forked thread before any --- asynchronous exceptions are received. -block :: IO a -> IO a - --- | To re-enable asynchronous exceptions inside the scope of --- 'block', 'unblock' can be --- used. It scopes in exactly the same way, so on exit from --- 'unblock' asynchronous exception delivery will --- be disabled again. -unblock :: IO a -> IO a - -block (IO io) = IO $ blockAsyncExceptions# io -unblock (IO io) = IO $ unblockAsyncExceptions# io - --- | returns True if asynchronous exceptions are blocked in the --- current thread. -blocked :: IO Bool -blocked = IO $ \s -> case asyncExceptionsBlocked# s of - (# s', i #) -> (# s', i /=# 0# #) -\end{code} - -\begin{code} --- | Forces its argument to be evaluated to weak head normal form when --- the resultant 'IO' action is executed. It can be used to order --- evaluation with respect to other 'IO' operations; its semantics are --- given by --- --- > evaluate x `seq` y ==> y --- > evaluate x `catch` f ==> (return $! x) `catch` f --- > evaluate x >>= f ==> (return $! x) >>= f --- --- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the --- same as @(return $! x)@. A correct definition is --- --- > evaluate x = (return $! x) >>= return --- -evaluate :: a -> IO a -evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) - -- NB. can't write - -- a `seq` (# s, a #) - -- because we can't have an unboxed tuple as a function argument -\end{code} - -\begin{code} -assertError :: Addr# -> Bool -> a -> a -assertError str predicate v - | predicate = v - | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) - -{- -(untangle coded message) expects "coded" to be of the form - "location|details" -It prints - location message details --} -untangle :: Addr# -> String -> String -untangle coded message - = location - ++ ": " - ++ message - ++ details - ++ "\n" - where - coded_str = unpackCStringUtf8# coded - - (location, details) - = case (span not_bar coded_str) of { (loc, rest) -> - case rest of - ('|':det) -> (loc, ' ' : det) - _ -> (loc, "") - } - not_bar c = c /= '|' -\end{code} - diff --git a/lib/base/src/GHC/IORef.hs b/lib/base/src/GHC/IORef.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/IORef.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IORef +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IORef type +-- +----------------------------------------------------------------------------- +module GHC.IORef ( + IORef(..), + newIORef, readIORef, writeIORef, atomicModifyIORef + ) where + +import GHC.Base +import GHC.STRef +import GHC.IO + +-- --------------------------------------------------------------------------- +-- IORefs + +-- |A mutable variable in the 'IO' monad +newtype IORef a = IORef (STRef RealWorld a) + +-- explicit instance because Haddock can't figure out a derived one +instance Eq (IORef a) where + IORef x == IORef y = x == y + +-- |Build a new 'IORef' +newIORef :: a -> IO (IORef a) +newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) + +-- |Read the value of an 'IORef' +readIORef :: IORef a -> IO a +readIORef (IORef var) = stToIO (readSTRef var) + +-- |Write a new value into an 'IORef' +writeIORef :: IORef a -> a -> IO () +writeIORef (IORef var) v = stToIO (writeSTRef var v) + +atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s + diff --git a/lib/base/src/GHC/Int.hs b/lib/base/src/GHC/Int.hs --- a/lib/base/src/GHC/Int.hs +++ b/lib/base/src/GHC/Int.hs @@ -14,9 +14,6 @@ -- ----------------------------------------------------------------------------- -#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#) -#define WORD_SIZE_IN_BITS (WORD_SIZE * 8) - -- #hide module GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..), @@ -25,10 +22,10 @@ import Data.Bits -#if WORD_SIZE < 4 +#if WORD_SIZE_IN_BITS < 32 import GHC.IntWord32 #endif -#if WORD_SIZE < 8 +#if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #endif @@ -38,6 +35,7 @@ import GHC.Real import GHC.Read import GHC.Arr +import GHC.Err import GHC.Word hiding (uncheckedShiftL64#, uncheckedShiftRL64#) import GHC.Show @@ -142,15 +140,11 @@ = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (8# -# i'#))))) where - x'# = narrow8Word# (int2Word# x#) - i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) + !x'# = narrow8Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) bitSize _ = 8 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8 "fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#) @@ -258,14 +252,11 @@ = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (16# -# i'#))))) where - x'# = narrow16Word# (int2Word# x#) - i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) + !x'# = narrow16Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) bitSize _ = 16 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) {-# RULES "fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#) @@ -399,9 +390,6 @@ bitSize _ = 32 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) {-# RULES "fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#) @@ -507,16 +495,14 @@ = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (32# -# i'#))))) where - x'# = narrow32Word# (int2Word# x#) - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) + !x'# = narrow32Word# (int2Word# x#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES +"fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (narrow32Int# x#) +"fromInteger/Int->Int32" forall x. fromInteger (smallInteger x) = I32# (narrow32Int# x) "fromIntegral/Word8->Int32" fromIntegral = \(W8# x#) -> I32# (word2Int# x#) "fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#) "fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# x# @@ -634,7 +620,7 @@ = if r# `neInt64#` intToInt64# 0# then r# `plusInt64#` y# else intToInt64# 0# | otherwise = r# where - r# = x# `remInt64#` y# + !r# = x# `remInt64#` y# instance Read Int64 where readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] @@ -656,16 +642,11 @@ = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#` (x'# `uncheckedShiftRL64#` (64# -# i'#)))) where - x'# = int64ToWord64# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) + !x'# = int64ToWord64# x# + !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - - -- give the 64-bit shift operations the same treatment as the 32-bit -- ones (see GHC.Base), namely we wrap them in tests to catch the -- cases when we're shifting more than 64 bits to avoid unspecified @@ -774,16 +755,13 @@ = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (64# -# i'#)))) where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) + !x'# = int2Word# x# + !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES +"fromInteger/Int->Int64" forall x. fromInteger (smallInteger x) = I64# x "fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x# "fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#) #-} @@ -806,4 +784,3 @@ range (m,n) = [m..n] unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n - diff --git a/lib/base/src/GHC/List.lhs b/lib/base/src/GHC/List.lhs --- a/lib/base/src/GHC/List.lhs +++ b/lib/base/src/GHC/List.lhs @@ -89,7 +89,7 @@ #endif -- | Return all the elements of a list except the last one. --- The list must be finite and non-empty. +-- The list must be non-empty. init :: [a] -> [a] #ifdef USE_REPORT_PRELUDE init [x] = [] @@ -108,7 +108,7 @@ null [] = True null (_:_) = False --- | 'length' returns the length of a finite list as an 'Int'. +-- | /O(n)/. 'length' returns the length of a finite list as an 'Int'. -- It is an instance of the more general 'Data.List.genericLength', -- the result type of which may be any kind of number. length :: [a] -> Int @@ -647,7 +647,7 @@ {-# INLINE [0] zipFB #-} zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d -zipFB c x y r = (x,y) `c` r +zipFB c = \x y r -> (x,y) `c` r {-# RULES "zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) @@ -680,9 +680,11 @@ zipWith f (a:as) (b:bs) = f a b : zipWith f as bs zipWith _ _ _ = [] +-- zipWithFB must have arity 2 since it gets two arguments in the "zipWith" +-- rule; it might not get inlined otherwise {-# INLINE [0] zipWithFB #-} zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c -zipWithFB c f x y r = (x `f` y) `c` r +zipWithFB c f = \x y r -> (x `f` y) `c` r {-# RULES "zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) diff --git a/lib/base/src/GHC/MVar.hs b/lib/base/src/GHC/MVar.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/MVar.hs @@ -0,0 +1,143 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.MVar +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The MVar type +-- +----------------------------------------------------------------------------- + +module GHC.MVar ( + -- * MVars + MVar(..) + , newMVar -- :: a -> IO (MVar a) + , newEmptyMVar -- :: IO (MVar a) + , takeMVar -- :: MVar a -> IO a + , putMVar -- :: MVar a -> a -> IO () + , tryTakeMVar -- :: MVar a -> IO (Maybe a) + , tryPutMVar -- :: MVar a -> a -> IO Bool + , isEmptyMVar -- :: MVar a -> IO Bool + , addMVarFinalizer -- :: MVar a -> IO () -> IO () + + ) where + +import GHC.Base +import GHC.IO() -- instance Monad IO +import Data.Maybe + +data MVar a = MVar (MVar# RealWorld a) +{- ^ +An 'MVar' (pronounced \"em-var\") is a synchronising variable, used +for communication between concurrent threads. It can be thought of +as a a box, which may be empty or full. +-} + +-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module +instance Eq (MVar a) where + (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# + +{- +M-Vars are rendezvous points for concurrent threads. They begin +empty, and any attempt to read an empty M-Var blocks. When an M-Var +is written, a single blocked thread may be freed. Reading an M-Var +toggles its state from full back to empty. Therefore, any value +written to an M-Var may only be read once. Multiple reads and writes +are allowed, but there must be at least one read between any two +writes. +-} + +--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) + +-- |Create an 'MVar' which is initially empty. +newEmptyMVar :: IO (MVar a) +newEmptyMVar = IO $ \ s# -> + case newMVar# s# of + (# s2#, svar# #) -> (# s2#, MVar svar# #) + +-- |Create an 'MVar' which contains the supplied value. +newMVar :: a -> IO (MVar a) +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +-- |Return the contents of the 'MVar'. If the 'MVar' is currently +-- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', +-- the 'MVar' is left empty. +-- +-- There are two further important properties of 'takeMVar': +-- +-- * 'takeMVar' is single-wakeup. That is, if there are multiple +-- threads blocked in 'takeMVar', and the 'MVar' becomes full, +-- only one thread will be woken up. The runtime guarantees that +-- the woken thread completes its 'takeMVar' operation. +-- +-- * When multiple threads are blocked on an 'MVar', they are +-- woken up in FIFO order. This is useful for providing +-- fairness properties of abstractions built using 'MVar's. +-- +takeMVar :: MVar a -> IO a +takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# + +-- |Put a value into an 'MVar'. If the 'MVar' is currently full, +-- 'putMVar' will wait until it becomes empty. +-- +-- There are two further important properties of 'putMVar': +-- +-- * 'putMVar' is single-wakeup. That is, if there are multiple +-- threads blocked in 'putMVar', and the 'MVar' becomes empty, +-- only one thread will be woken up. The runtime guarantees that +-- the woken thread completes its 'putMVar' operation. +-- +-- * When multiple threads are blocked on an 'MVar', they are +-- woken up in FIFO order. This is useful for providing +-- fairness properties of abstractions built using 'MVar's. +-- +putMVar :: MVar a -> a -> IO () +putMVar (MVar mvar#) x = IO $ \ s# -> + case putMVar# mvar# x s# of + s2# -> (# s2#, () #) + +-- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function +-- returns immediately, with 'Nothing' if the 'MVar' was empty, or +-- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', +-- the 'MVar' is left empty. +tryTakeMVar :: MVar a -> IO (Maybe a) +tryTakeMVar (MVar m) = IO $ \ s -> + case tryTakeMVar# m s of + (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty + (# s', _, a #) -> (# s', Just a #) -- MVar is full + +-- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function +-- attempts to put the value @a@ into the 'MVar', returning 'True' if +-- it was successful, or 'False' otherwise. +tryPutMVar :: MVar a -> a -> IO Bool +tryPutMVar (MVar mvar#) x = IO $ \ s# -> + case tryPutMVar# mvar# x s# of + (# s, 0# #) -> (# s, False #) + (# s, _ #) -> (# s, True #) + +-- |Check whether a given 'MVar' is empty. +-- +-- Notice that the boolean value returned is just a snapshot of +-- the state of the MVar. By the time you get to react on its result, +-- the MVar may have been filled (or emptied) - so be extremely +-- careful when using this operation. Use 'tryTakeMVar' instead if possible. +isEmptyMVar :: MVar a -> IO Bool +isEmptyMVar (MVar mv#) = IO $ \ s# -> + case isEmptyMVar# mv# s# of + (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) + +-- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and +-- "System.Mem.Weak" for more about finalizers. +addMVarFinalizer :: MVar a -> IO () -> IO () +addMVarFinalizer (MVar m) finalizer = + IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } + diff --git a/lib/base/src/GHC/Num.lhs b/lib/base/src/GHC/Num.lhs --- a/lib/base/src/GHC/Num.lhs +++ b/lib/base/src/GHC/Num.lhs @@ -1,4 +1,7 @@ \begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +-- We believe we could deorphan this module, by moving lots of things +-- around, but we haven't got there yet: {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -6,7 +9,7 @@ -- Module : GHC.Num -- Copyright : (c) The University of Glasgow 1994-2002 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -39,7 +42,7 @@ infixl 7 * infixl 6 +, - -default () -- Double isn't available yet, +default () -- Double isn't available yet, -- and we shouldn't be using defaults anyway \end{code} @@ -60,7 +63,7 @@ -- | Absolute value. abs :: a -> a -- | Sign of a number. - -- The functions 'abs' and 'signum' should satisfy the law: + -- The functions 'abs' and 'signum' should satisfy the law: -- -- > abs x * signum x == x -- @@ -73,6 +76,8 @@ -- so such literals have type @('Num' a) => a@. fromInteger :: Integer -> a + {-# INLINE (-) #-} + {-# INLINE negate #-} x - y = x + negate y negate x = 0 - x @@ -118,27 +123,6 @@ %********************************************************* %* * -\subsection{The @Integer@ instances for @Eq@, @Ord@} -%* * -%********************************************************* - -\begin{code} -instance Eq Integer where - (==) = eqInteger - (/=) = neqInteger - ------------------------------------------------------------------------- -instance Ord Integer where - (<=) = leInteger - (>) = gtInteger - (<) = ltInteger - (>=) = geInteger - compare = compareInteger -\end{code} - - -%********************************************************* -%* * \subsection{The @Integer@ instances for @Show@} %* * %********************************************************* @@ -178,8 +162,8 @@ jsplith p (n:ns) = case n `quotRemInteger` p of (# q, r #) -> - if q > 0 then fromInteger q : fromInteger r : jsplitb p ns - else fromInteger r : jsplitb p ns + if q > 0 then q : r : jsplitb p ns + else r : jsplitb p ns jsplith _ [] = error "jsplith: []" jsplitb :: Integer -> [Integer] -> [Integer] @@ -291,6 +275,8 @@ -- head (drop 1000000 [1 .. ] -- works +{-# NOINLINE [0] enumDeltaToIntegerFB #-} +-- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire enumDeltaToIntegerFB :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a enumDeltaToIntegerFB c n x delta lim diff --git a/lib/base/src/GHC/PArr.hs b/lib/base/src/GHC/PArr.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/PArr.hs @@ -0,0 +1,732 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE PArr #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.PArr +-- Copyright : (c) 2001-2002 Manuel M T Chakravarty & Gabriele Keller +-- License : see libraries/base/LICENSE +-- +-- Maintainer : Manuel M. T. Chakravarty +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Basic implementation of Parallel Arrays. +-- +-- This module has two functions: (1) It defines the interface to the +-- parallel array extension of the Prelude and (2) it provides a vanilla +-- implementation of parallel arrays that does not require to flatten the +-- array code. The implementation is not very optimised. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 plus unboxed values and parallel arrays +-- +-- The semantic difference between standard Haskell arrays (aka "lazy +-- arrays") and parallel arrays (aka "strict arrays") is that the evaluation +-- of two different elements of a lazy array is independent, whereas in a +-- strict array either non or all elements are evaluated. In other words, +-- when a parallel array is evaluated to WHNF, all its elements will be +-- evaluated to WHNF. The name parallel array indicates that all array +-- elements may, in general, be evaluated to WHNF in parallel without any +-- need to resort to speculative evaluation. This parallel evaluation +-- semantics is also beneficial in the sequential case, as it facilitates +-- loop-based array processing as known from classic array-based languages, +-- such as Fortran. +-- +-- The interface of this module is essentially a variant of the list +-- component of the Prelude, but also includes some functions (such as +-- permutations) that are not provided for lists. The following list +-- operations are not supported on parallel arrays, as they would require the +-- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'. +-- +-- The current implementation is quite simple and entirely based on boxed +-- arrays. One disadvantage of boxed arrays is that they require to +-- immediately initialise all newly allocated arrays with an error thunk to +-- keep the garbage collector happy, even if it is guaranteed that the array +-- is fully initialised with different values before passing over the +-- user-visible interface boundary. Currently, no effort is made to use +-- raw memory copy operations to speed things up. +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * We probably want a standard library `PArray' in addition to the prelude +-- extension in the same way as the standard library `List' complements the +-- list functions from the prelude. +-- +-- * Currently, functions that emphasis the constructor-based definition of +-- lists (such as, head, last, tail, and init) are not supported. +-- +-- Is it worthwhile to support the string processing functions lines, +-- words, unlines, and unwords? (Currently, they are not implemented.) +-- +-- It can, however, be argued that it would be worthwhile to include them +-- for completeness' sake; maybe only in the standard library `PArray'. +-- +-- * Prescans are often more useful for array programming than scans. Shall +-- we include them into the Prelude or the library? +-- +-- * Due to the use of the iterator `loop', we could define some fusion rules +-- in this module. +-- +-- * We might want to add bounds checks that can be deactivated. +-- + +module GHC.PArr ( + -- [::], -- Built-in syntax + + mapP, -- :: (a -> b) -> [:a:] -> [:b:] + (+:+), -- :: [:a:] -> [:a:] -> [:a:] + filterP, -- :: (a -> Bool) -> [:a:] -> [:a:] + concatP, -- :: [:[:a:]:] -> [:a:] + concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:] +-- head, last, tail, init, -- it's not wise to use them on arrays + nullP, -- :: [:a:] -> Bool + lengthP, -- :: [:a:] -> Int + (!:), -- :: [:a:] -> Int -> a + foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a + foldl1P, -- :: (a -> a -> a) -> [:a:] -> a + scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:] + scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] + foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b + foldr1P, -- :: (a -> a -> a) -> [:a:] -> a + scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:] + scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] +-- iterate, repeat, -- parallel arrays must be finite + singletonP, -- :: a -> [:a:] + emptyP, -- :: [:a:] + replicateP, -- :: Int -> a -> [:a:] +-- cycle, -- parallel arrays must be finite + takeP, -- :: Int -> [:a:] -> [:a:] + dropP, -- :: Int -> [:a:] -> [:a:] + splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:]) + takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] + dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] + spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) + breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +-- lines, words, unlines, unwords, -- is string processing really needed + reverseP, -- :: [:a:] -> [:a:] + andP, -- :: [:Bool:] -> Bool + orP, -- :: [:Bool:] -> Bool + anyP, -- :: (a -> Bool) -> [:a:] -> Bool + allP, -- :: (a -> Bool) -> [:a:] -> Bool + elemP, -- :: (Eq a) => a -> [:a:] -> Bool + notElemP, -- :: (Eq a) => a -> [:a:] -> Bool + lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b + sumP, -- :: (Num a) => [:a:] -> a + productP, -- :: (Num a) => [:a:] -> a + maximumP, -- :: (Ord a) => [:a:] -> a + minimumP, -- :: (Ord a) => [:a:] -> a + zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :] + zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] + zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] + zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] + unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:]) + unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) + + -- overloaded functions + -- + enumFromToP, -- :: Enum a => a -> a -> [:a:] + enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:] + + -- the following functions are not available on lists + -- + toP, -- :: [a] -> [:a:] + fromP, -- :: [:a:] -> [a] + sliceP, -- :: Int -> Int -> [:e:] -> [:e:] + foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e + fold1P, -- :: (e -> e -> e) -> [:e:] -> e + permuteP, -- :: [:Int:] -> [:e:] -> [:e:] + bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] + dpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:] + crossP, -- :: [:a:] -> [:b:] -> [:(a, b):] + crossMapP, -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):] + indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:] +) where + +#ifndef __HADDOCK__ + +import Prelude + +import GHC.ST ( ST(..), runST ) +import GHC.Base ( Int#, Array#, Int(I#), MutableArray#, newArray#, + unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) ) + +infixl 9 !: +infixr 5 +:+ +infix 4 `elemP`, `notElemP` + + +-- representation of parallel arrays +-- --------------------------------- + +-- this rather straight forward implementation maps parallel arrays to the +-- internal representation used for standard Haskell arrays in GHC's Prelude +-- (EXPORTED ABSTRACTLY) +-- +-- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! +-- +data [::] e = PArr Int# (Array# e) + + +-- exported operations on parallel arrays +-- -------------------------------------- + +-- operations corresponding to list operations +-- + +mapP :: (a -> b) -> [:a:] -> [:b:] +mapP f = fst . loop (mapEFL f) noAL + +(+:+) :: [:a:] -> [:a:] -> [:a:] +a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1)) + -- we can't use the [:x..y:] form here for tedious + -- reasons to do with the typechecker and the fact that + -- `enumFromToP' is defined in the same module + where + len1 = lengthP a1 + len2 = lengthP a2 + -- + sel i | i < len1 = a1!:i + | otherwise = a2!:(i - len1) + +filterP :: (a -> Bool) -> [:a:] -> [:a:] +filterP p = fst . loop (filterEFL p) noAL + +concatP :: [:[:a:]:] -> [:a:] +concatP xss = foldlP (+:+) [::] xss + +concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:] +concatMapP f = concatP . mapP f + +-- head, last, tail, init, -- it's not wise to use them on arrays + +nullP :: [:a:] -> Bool +nullP [::] = True +nullP _ = False + +lengthP :: [:a:] -> Int +lengthP (PArr n# _) = I# n# + +(!:) :: [:a:] -> Int -> a +(!:) = indexPArr + +foldlP :: (a -> b -> a) -> a -> [:b:] -> a +foldlP f z = snd . loop (foldEFL (flip f)) z + +foldl1P :: (a -> a -> a) -> [:a:] -> a +foldl1P _ [::] = error "Prelude.foldl1P: empty array" +foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a + +scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:] +scanlP f z = fst . loop (scanEFL (flip f)) z + +scanl1P :: (a -> a -> a) -> [:a:] -> [:a:] +scanl1P _ [::] = error "Prelude.scanl1P: empty array" +scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a + +foldrP :: (a -> b -> b) -> b -> [:a:] -> b +foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME + +foldr1P :: (a -> a -> a) -> [:a:] -> a +foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME + +scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:] +scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME + +scanr1P :: (a -> a -> a) -> [:a:] -> [:a:] +scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME + +-- iterate, repeat -- parallel arrays must be finite + +singletonP :: a -> [:a:] +{-# INLINE singletonP #-} +singletonP e = replicateP 1 e + +emptyP:: [:a:] +{- NOINLINE emptyP #-} +emptyP = replicateP 0 undefined + + +replicateP :: Int -> a -> [:a:] +{-# INLINE replicateP #-} +replicateP n e = runST (do + marr# <- newArray n e + mkPArr n marr#) + +-- cycle -- parallel arrays must be finite + +takeP :: Int -> [:a:] -> [:a:] +takeP n = sliceP 0 (n - 1) + +dropP :: Int -> [:a:] -> [:a:] +dropP n a = sliceP n (lengthP a - 1) a + +splitAtP :: Int -> [:a:] -> ([:a:],[:a:]) +splitAtP n xs = (takeP n xs, dropP n xs) + +takeWhileP :: (a -> Bool) -> [:a:] -> [:a:] +takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME + +dropWhileP :: (a -> Bool) -> [:a:] -> [:a:] +dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME + +spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +spanP = error "Prelude.spanP: not implemented yet" -- FIXME + +breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +breakP p = spanP (not . p) + +-- lines, words, unlines, unwords, -- is string processing really needed + +reverseP :: [:a:] -> [:a:] +reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a + -- we can't use the [:x, y..z:] form here for tedious + -- reasons to do with the typechecker and the fact that + -- `enumFromThenToP' is defined in the same module + where + len = lengthP a + +andP :: [:Bool:] -> Bool +andP = foldP (&&) True + +orP :: [:Bool:] -> Bool +orP = foldP (||) True + +anyP :: (a -> Bool) -> [:a:] -> Bool +anyP p = orP . mapP p + +allP :: (a -> Bool) -> [:a:] -> Bool +allP p = andP . mapP p + +elemP :: (Eq a) => a -> [:a:] -> Bool +elemP x = anyP (== x) + +notElemP :: (Eq a) => a -> [:a:] -> Bool +notElemP x = allP (/= x) + +lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b +lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME + +sumP :: (Num a) => [:a:] -> a +sumP = foldP (+) 0 + +productP :: (Num a) => [:a:] -> a +productP = foldP (*) 1 + +maximumP :: (Ord a) => [:a:] -> a +maximumP [::] = error "Prelude.maximumP: empty parallel array" +maximumP xs = fold1P max xs + +minimumP :: (Ord a) => [:a:] -> a +minimumP [::] = error "Prelude.minimumP: empty parallel array" +minimumP xs = fold1P min xs + +zipP :: [:a:] -> [:b:] -> [:(a, b):] +zipP = zipWithP (,) + +zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] +zip3P = zipWith3P (,,) + +zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] +zipWithP f a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + len = len1 `min` len2 + in + fst $ loopFromTo 0 (len - 1) combine 0 a1 + where + combine e1 i = (Just $ f e1 (a2!:i), i + 1) + +zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] +zipWith3P f a1 a2 a3 = let + len1 = lengthP a1 + len2 = lengthP a2 + len3 = lengthP a3 + len = len1 `min` len2 `min` len3 + in + fst $ loopFromTo 0 (len - 1) combine 0 a1 + where + combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1) + +unzipP :: [:(a, b):] -> ([:a:], [:b:]) +unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a) +-- FIXME: these two functions should be optimised using a tupled custom loop +unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) +unzip3P x = (fst $ loop (mapEFL fst3) noAL x, + fst $ loop (mapEFL snd3) noAL x, + fst $ loop (mapEFL trd3) noAL x) + where + fst3 (a, _, _) = a + snd3 (_, b, _) = b + trd3 (_, _, c) = c + +-- instances +-- + +instance Eq a => Eq [:a:] where + a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2) + | otherwise = False + +instance Ord a => Ord [:a:] where + compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of + EQ | lengthP a1 == lengthP a2 -> EQ + | lengthP a1 < lengthP a2 -> LT + | otherwise -> GT + where + combineOrdering EQ EQ = EQ + combineOrdering EQ other = other + combineOrdering other _ = other + +instance Functor [::] where + fmap = mapP + +instance Monad [::] where + m >>= k = foldrP ((+:+) . k ) [::] m + m >> k = foldrP ((+:+) . const k) [::] m + return x = [:x:] + fail _ = [::] + +instance Show a => Show [:a:] where + showsPrec _ = showPArr . fromP + where + showPArr [] s = "[::]" ++ s + showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s) + + showPArr' [] s = ":]" ++ s + showPArr' (y:ys) s = ',' : shows y (showPArr' ys s) + +instance Read a => Read [:a:] where + readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a] + where + readPArr = readParen False (\r -> do + ("[:",s) <- lex r + readPArr1 s) + readPArr1 s = + (do { (":]", t) <- lex s; return ([], t) }) ++ + (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) }) + + readPArr2 s = + (do { (":]", t) <- lex s; return ([], t) }) ++ + (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; + return (x:xs, v) }) + +-- overloaded functions +-- + +-- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of +-- `Enum'. On the other hand, we really do not want to change `Enum'. Thus, +-- for the moment, we hope that the compiler is sufficiently clever to +-- properly fuse the following definitions. + +enumFromToP :: Enum a => a -> a -> [:a:] +enumFromToP x0 y0 = mapP toEnum (eftInt (fromEnum x0) (fromEnum y0)) + where + eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1 + +enumFromThenToP :: Enum a => a -> a -> a -> [:a:] +enumFromThenToP x0 y0 z0 = + mapP toEnum (efttInt (fromEnum x0) (fromEnum y0) (fromEnum z0)) + where + efttInt x y z = scanlP (+) x $ + replicateP (abs (z - x) `div` abs delta + 1) delta + where + delta = y - x + +-- the following functions are not available on lists +-- + +-- create an array from a list (EXPORTED) +-- +toP :: [a] -> [:a:] +toP l = fst $ loop store l (replicateP (length l) ()) + where + store _ (x:xs) = (Just x, xs) + +-- convert an array to a list (EXPORTED) +-- +fromP :: [:a:] -> [a] +fromP a = [a!:i | i <- [0..lengthP a - 1]] + +-- cut a subarray out of an array (EXPORTED) +-- +sliceP :: Int -> Int -> [:e:] -> [:e:] +sliceP from to a = + fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a + +-- parallel folding (EXPORTED) +-- +-- * the first argument must be associative; otherwise, the result is undefined +-- +foldP :: (e -> e -> e) -> e -> [:e:] -> e +foldP = foldlP + +-- parallel folding without explicit neutral (EXPORTED) +-- +-- * the first argument must be associative; otherwise, the result is undefined +-- +fold1P :: (e -> e -> e) -> [:e:] -> e +fold1P = foldl1P + +-- permute an array according to the permutation vector in the first argument +-- (EXPORTED) +-- +permuteP :: [:Int:] -> [:e:] -> [:e:] +permuteP is es + | isLen /= esLen = error "GHC.PArr: arguments must be of the same length" + | otherwise = runST (do + marr <- newArray isLen noElem + permute marr is es + mkPArr isLen marr) + where + noElem = error "GHC.PArr.permuteP: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + isLen = lengthP is + esLen = lengthP es + +-- permute an array according to the back-permutation vector in the first +-- argument (EXPORTED) +-- +-- * the permutation vector must represent a surjective function; otherwise, +-- the result is undefined +-- +bpermuteP :: [:Int:] -> [:e:] -> [:e:] +bpermuteP is es = fst $ loop (mapEFL (es!:)) noAL is + +-- permute an array according to the permutation vector in the first +-- argument, which need not be surjective (EXPORTED) +-- +-- * any elements in the result that are not covered by the permutation +-- vector assume the value of the corresponding position of the third +-- argument +-- +dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:] +dpermuteP is es dft + | isLen /= esLen = error "GHC.PArr: arguments must be of the same length" + | otherwise = runST (do + marr <- newArray dftLen noElem + _ <- trans 0 (isLen - 1) marr dft copyOne noAL + permute marr is es + mkPArr dftLen marr) + where + noElem = error "GHC.PArr.permuteP: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + isLen = lengthP is + esLen = lengthP es + dftLen = lengthP dft + + copyOne e _ = (Just e, noAL) + +-- computes the cross combination of two arrays (EXPORTED) +-- +crossP :: [:a:] -> [:b:] -> [:(a, b):] +crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len () + where + len1 = lengthP a1 + len2 = lengthP a2 + len = len1 * len2 + -- + combine _ (i, j) = (Just $ (a1!:i, a2!:j), next) + where + next | (i + 1) == len1 = (0 , j + 1) + | otherwise = (i + 1, j) + +{- An alternative implementation + * The one above is certainly better for flattened code, but here where we + are handling boxed arrays, the trade off is less clear. However, I + think, the above one is still better. + +crossP a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + x1 = concatP $ mapP (replicateP len2) a1 + x2 = concatP $ replicateP len1 a2 + in + zipP x1 x2 + -} + +-- |Compute a cross of an array and the arrays produced by the given function +-- for the elements of the first array. +-- +crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):] +crossMapP a f = let + bs = mapP f a + segd = mapP lengthP bs + as = zipWithP replicateP segd a + in + zipP (concatP as) (concatP bs) + +{- The following may seem more straight forward, but the above is very cheap + with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are + constant time, and `map f' uses the lifted version of `f'. + +crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a + + -} + +-- computes an index array for all elements of the second argument for which +-- the predicate yields `True' (EXPORTED) +-- +indexOfP :: (a -> Bool) -> [:a:] -> [:Int:] +indexOfP p a = fst $ loop calcIdx 0 a + where + calcIdx e idx | p e = (Just idx, idx + 1) + | otherwise = (Nothing , idx ) + + +-- auxiliary functions +-- ------------------- + +-- internally used mutable boxed arrays +-- +data MPArr s e = MPArr Int# (MutableArray# s e) + +-- allocate a new mutable array that is pre-initialised with a given value +-- +newArray :: Int -> e -> ST s (MPArr s e) +{-# INLINE newArray #-} +newArray (I# n#) e = ST $ \s1# -> + case newArray# n# e s1# of { (# s2#, marr# #) -> + (# s2#, MPArr n# marr# #)} + +-- convert a mutable array into the external parallel array representation +-- +mkPArr :: Int -> MPArr s e -> ST s [:e:] +{-# INLINE mkPArr #-} +mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# -> + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, PArr n# arr# #) } + +-- general array iterator +-- +-- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty & +-- Keller, ICFP 2001 +-- +loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element + -> acc -- initial acc value + -> [:e:] -- input array + -> ([:e':], acc) +{-# INLINE loop #-} +loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr + +-- general array iterator with bounds +-- +loopFromTo :: Int -- from index + -> Int -- to index + -> (e -> acc -> (Maybe e', acc)) + -> acc + -> [:e:] + -> ([:e':], acc) +{-# INLINE loopFromTo #-} +loopFromTo from to mf start arr = runST (do + marr <- newArray (to - from + 1) noElem + (n', acc) <- trans from to marr arr mf start + arr' <- mkPArr n' marr + return (arr', acc)) + where + noElem = error "GHC.PArr.loopFromTo: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + +-- actual loop body of `loop' +-- +-- * for this to be really efficient, it has to be translated with the +-- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03 +-- this requires an optimisation level of at least -O2 +-- +trans :: Int -- index of first elem to process + -> Int -- index of last elem to process + -> MPArr s e' -- destination array + -> [:e:] -- source array + -> (e -> acc -> (Maybe e', acc)) -- mutator + -> acc -- initial accumulator + -> ST s (Int, acc) -- final destination length/final acc +{-# INLINE trans #-} +trans from to marr arr mf start = trans' from 0 start + where + trans' arrOff marrOff acc + | arrOff > to = return (marrOff, acc) + | otherwise = do + let (oe', acc') = mf (arr `indexPArr` arrOff) acc + marrOff' <- case oe' of + Nothing -> return marrOff + Just e' -> do + writeMPArr marr marrOff e' + return $ marrOff + 1 + trans' (arrOff + 1) marrOff' acc' + +-- Permute the given elements into the mutable array. +-- +permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s () +permute marr is es = perm 0 + where + perm i + | i == n = return () + | otherwise = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1) + where + n = lengthP is + + +-- common patterns for using `loop' +-- + +-- initial value for the accumulator when the accumulator is not needed +-- +noAL :: () +noAL = () + +-- `loop' mutator maps a function over array elements +-- +mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ())) +{-# INLINE mapEFL #-} +mapEFL f = \e _ -> (Just $ f e, ()) + +-- `loop' mutator that filter elements according to a predicate +-- +filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ())) +{-# INLINE filterEFL #-} +filterEFL p = \e _ -> if p e then (Just e, ()) else (Nothing, ()) + +-- `loop' mutator for array folding +-- +foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc)) +{-# INLINE foldEFL #-} +foldEFL f = \e a -> (Nothing, f e a) + +-- `loop' mutator for array scanning +-- +scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc)) +{-# INLINE scanEFL #-} +scanEFL f = \e a -> (Just a, f e a) + +-- elementary array operations +-- + +-- unlifted array indexing +-- +indexPArr :: [:e:] -> Int -> e +{-# INLINE indexPArr #-} +indexPArr (PArr n# arr#) (I# i#) + | i# >=# 0# && i# <# n# = + case indexArray# arr# i# of (# e #) -> e + | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++ + "idx = " ++ show (I# i#) ++ ", arr len = " + ++ show (I# n#) + +-- encapsulate writing into a mutable array into the `ST' monad +-- +writeMPArr :: MPArr s e -> Int -> e -> ST s () +{-# INLINE writeMPArr #-} +writeMPArr (MPArr n# marr#) (I# i#) e + | i# >=# 0# && i# <# n# = + ST $ \s# -> + case writeArray# marr# i# e s# of s'# -> (# s'#, () #) + | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++ + "idx = " ++ show (I# i#) ++ ", arr len = " + ++ show (I# n#) + +#endif /* __HADDOCK__ */ + diff --git a/lib/base/src/GHC/Pack.lhs b/lib/base/src/GHC/Pack.lhs --- a/lib/base/src/GHC/Pack.lhs +++ b/lib/base/src/GHC/Pack.lhs @@ -35,7 +35,6 @@ where import GHC.Base -import GHC.Err ( error ) import GHC.List ( length ) import GHC.ST import GHC.Num diff --git a/lib/base/src/GHC/Ptr.lhs b/lib/base/src/GHC/Ptr.lhs --- a/lib/base/src/GHC/Ptr.lhs +++ b/lib/base/src/GHC/Ptr.lhs @@ -24,6 +24,7 @@ import GHC.List ( length, replicate ) import Numeric ( showHex ) + ------------------------------------------------------------------------ -- Data pointers. @@ -143,19 +144,15 @@ ------------------------------------------------------------------------ -- Show instances for Ptr and FunPtr --- I have absolutely no idea why the WORD_SIZE_IN_BITS stuff is here -#if (WORD_SIZE == 4 || WORD_SIZE == 8) -#define SIZEOF_HSPTR WORD_SIZE instance Show (Ptr a) where showsPrec _ (Ptr a) rs = pad_out (showHex (wordToInteger(int2Word#(addr2Int# a))) "") where -- want 0s prefixed to pad it out to a fixed length. pad_out ls = - '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls ++ rs + '0':'x':(replicate (2*WORD_SIZE - length ls) '0') ++ ls ++ rs instance Show (FunPtr a) where showsPrec p = showsPrec p . castFunPtrToPtr -#endif \end{code} diff --git a/lib/base/src/GHC/Read.lhs b/lib/base/src/GHC/Read.lhs --- a/lib/base/src/GHC/Read.lhs +++ b/lib/base/src/GHC/Read.lhs @@ -70,7 +70,7 @@ import GHC.Float () import GHC.Show import GHC.Base ---import GHC.Arr +import GHC.Arr \end{code} @@ -421,7 +421,7 @@ readPrec = readListPrec readListPrec = readListPrecDefault readList = readListDefault -{- + instance (Ix a, Read a, Read b) => Read (Array a b) where readPrec = parens $ prec appPrec $ do L.Ident "array" <- lexP @@ -431,7 +431,7 @@ readListPrec = readListPrecDefault readList = readListDefault --} + instance Read L.Lexeme where readPrec = lexP readListPrec = readListPrecDefault diff --git a/lib/base/src/GHC/Real.lhs b/lib/base/src/GHC/Real.lhs --- a/lib/base/src/GHC/Real.lhs +++ b/lib/base/src/GHC/Real.lhs @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : GHC.Real --- Copyright : (c) The FFI Task Force, 1994-2002 +-- Copyright : (c) The University of Glasgow, 1994-2002 -- License : see libraries/base/LICENSE -- -- Maintainer : cvs-ghc@haskell.org @@ -24,6 +24,7 @@ import GHC.List import GHC.Enum import GHC.Show +import GHC.Err infixr 8 ^, ^^ infixl 7 /, `quot`, `rem`, `div`, `mod` @@ -132,10 +133,15 @@ -- | conversion to 'Integer' toInteger :: a -> Integer + {-# INLINE quot #-} + {-# INLINE rem #-} + {-# INLINE div #-} + {-# INLINE mod #-} n `quot` d = q where (q,_) = quotRem n d n `rem` d = r where (_,r) = quotRem n d n `div` d = q where (q,_) = divMod n d n `mod` d = r where (_,r) = divMod n d + divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr where qr@(q,r) = quotRem n d @@ -153,6 +159,8 @@ -- @('Fractional' a) => a@. fromRational :: Rational -> a + {-# INLINE recip #-} + {-# INLINE (/) #-} recip x = 1 / x x / y = x * recip y @@ -181,6 +189,7 @@ -- | @'floor' x@ returns the greatest integer not greater than @x@ floor :: (Integral b) => a -> b + {-# INLINE truncate #-} truncate x = m where (m,_) = properFraction x round x = let (n,r) = properFraction x @@ -448,18 +457,21 @@ lcm 0 _ = 0 lcm x y = abs ((x `quot` (gcd x y)) * y) +#ifdef OPTIMISE_INTEGER_GCD_LCM {-# RULES "gcd/Int->Int->Int" gcd = gcdInt "gcd/Integer->Integer->Integer" gcd = gcdInteger' "lcm/Integer->Integer->Integer" lcm = lcmInteger #-} --- XXX to use another Integer implementation, you might need to disable --- the gcd/Integer and lcm/Integer RULES above --- gcdInteger' :: Integer -> Integer -> Integer gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined" gcdInteger' a b = gcdInteger a b + +gcdInt :: Int -> Int -> Int +gcdInt 0 0 = error "GHC.Real.gcdInt: gcd 0 0 is undefined" +gcdInt a b = fromIntegral (gcdInteger (fromIntegral a) (fromIntegral b)) +#endif integralEnumFrom :: (Integral a, Bounded a) => a -> [a] integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)] diff --git a/lib/base/src/GHC/Show.lhs b/lib/base/src/GHC/Show.lhs --- a/lib/base/src/GHC/Show.lhs +++ b/lib/base/src/GHC/Show.lhs @@ -388,7 +388,7 @@ itos :: Int# -> String -> String itos n# cs | n# <# 0# = - let I# minInt# = minInt in + let !(I# minInt#) = minInt in if n# ==# minInt# -- negateInt# minInt overflows, so we can't do that: then '-' : itos' (negateInt# (n# `quotInt#` 10#)) diff --git a/lib/base/src/GHC/Show.lhs-boot b/lib/base/src/GHC/Show.lhs-boot new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/Show.lhs-boot @@ -0,0 +1,10 @@ +\begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Show (showSignedInt) where + +import GHC.Types + +showSignedInt :: Int -> Int -> [Char] -> [Char] +\end{code} + diff --git a/lib/base/src/GHC/Stable.lhs b/lib/base/src/GHC/Stable.lhs --- a/lib/base/src/GHC/Stable.lhs +++ b/lib/base/src/GHC/Stable.lhs @@ -27,7 +27,7 @@ import GHC.Ptr import GHC.Base -import GHC.IOBase +-- import GHC.IO ----------------------------------------------------------------------------- -- Stable Pointers diff --git a/lib/base/src/GHC/Storable.lhs b/lib/base/src/GHC/Storable.lhs --- a/lib/base/src/GHC/Storable.lhs +++ b/lib/base/src/GHC/Storable.lhs @@ -55,7 +55,6 @@ import GHC.Int import GHC.Word import GHC.Ptr -import GHC.IOBase import GHC.Base \end{code} diff --git a/lib/base/src/GHC/Unicode.hs b/lib/base/src/GHC/Unicode.hs --- a/lib/base/src/GHC/Unicode.hs +++ b/lib/base/src/GHC/Unicode.hs @@ -25,6 +25,7 @@ isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, toUpper, toLower, toTitle, + wgencat, ) where import GHC.Base @@ -74,7 +75,7 @@ c == '\f' || c == '\v' || c == '\xa0' || - False -- iswspace (fromIntegral (ord c)) /= 0 + 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 @@ -128,7 +129,7 @@ -- Implementation with the supplied auto-generated Unicode character properties -- table (default) -#if 0 +#if 1 -- Regardless of the O/S and Library, use the functions contained in WCsubst.c @@ -144,31 +145,31 @@ toUpper c = chr (fromIntegral (towupper (fromIntegral (ord c)))) toTitle c = chr (fromIntegral (towtitle (fromIntegral (ord c)))) -foreign import ccall unsafe "u_iswalpha" +foreign import ccall unsafe "iswalpha" iswalpha :: CInt -> CInt -foreign import ccall unsafe "u_iswalnum" +foreign import ccall unsafe "iswalnum" iswalnum :: CInt -> CInt -foreign import ccall unsafe "u_iswcntrl" +foreign import ccall unsafe "iswcntrl" iswcntrl :: CInt -> CInt -foreign import ccall unsafe "u_iswspace" +foreign import ccall unsafe "iswspace" iswspace :: CInt -> CInt -foreign import ccall unsafe "u_iswprint" +foreign import ccall unsafe "iswprint" iswprint :: CInt -> CInt -foreign import ccall unsafe "u_iswlower" +foreign import ccall unsafe "iswlower" iswlower :: CInt -> CInt -foreign import ccall unsafe "u_iswupper" +foreign import ccall unsafe "iswupper" iswupper :: CInt -> CInt -foreign import ccall unsafe "u_towlower" +foreign import ccall unsafe "towlower" towlower :: CInt -> CInt -foreign import ccall unsafe "u_towupper" +foreign import ccall unsafe "towupper" towupper :: CInt -> CInt foreign import ccall unsafe "u_towtitle" @@ -216,8 +217,6 @@ | isAscii c = c | isUpper c = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a') | otherwise = c - -toTitle c = c #endif diff --git a/lib/base/src/GHC/Weak.lhs b/lib/base/src/GHC/Weak.lhs new file mode 100644 --- /dev/null +++ b/lib/base/src/GHC/Weak.lhs @@ -0,0 +1,133 @@ +\begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Weak +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Weak pointers. +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.Weak where + +import GHC.Base +import Data.Maybe +import Data.Typeable + +{-| +A weak pointer object with a key and a value. The value has type @v@. + +A weak pointer expresses a relationship between two objects, the +/key/ and the /value/: if the key is considered to be alive by the +garbage collector, then the value is also alive. A reference from +the value to the key does /not/ keep the key alive. + +A weak pointer may also have a finalizer of type @IO ()@; if it does, +then the finalizer will be run at most once, at a time after the key +has become unreachable by the program (\"dead\"). The storage manager +attempts to run the finalizer(s) for an object soon after the object +dies, but promptness is not guaranteed. + +It is not guaranteed that a finalizer will eventually run, and no +attempt is made to run outstanding finalizers when the program exits. +Therefore finalizers should not be relied on to clean up resources - +other methods (eg. exception handlers) should be employed, possibly in +addition to finalisers. + +References from the finalizer to the key are treated in the same way +as references from the value to the key: they do not keep the key +alive. A finalizer may therefore ressurrect the key, perhaps by +storing it in the same data structure. + +The finalizer, and the relationship between the key and the value, +exist regardless of whether the program keeps a reference to the +'Weak' object or not. + +There may be multiple weak pointers with the same key. In this +case, the finalizers for each of these weak pointers will all be +run in some arbitrary order, or perhaps concurrently, when the key +dies. If the programmer specifies a finalizer that assumes it has +the only reference to an object (for example, a file that it wishes +to close), then the programmer must ensure that there is only one +such finalizer. + +If there are no other threads to run, the runtime system will check +for runnable finalizers before declaring the system to be deadlocked. +-} +data Weak v = Weak (Weak# v) + +#include "Typeable.h" +INSTANCE_TYPEABLE1(Weak,weakTc,"Weak") + +-- | Establishes a weak pointer to @k@, with value @v@ and a finalizer. +-- +-- This is the most general interface for building a weak pointer. +-- +mkWeak :: k -- ^ key + -> v -- ^ value + -> Maybe (IO ()) -- ^ finalizer + -> IO (Weak v) -- ^ returns: a weak pointer object + +mkWeak key val (Just finalizer) = IO $ \s -> + case mkWeak# key val finalizer s of { (# s1, w #) -> (# s1, Weak w #) } +mkWeak key val Nothing = IO $ \s -> + case mkWeak# key val (unsafeCoerce# 0#) s of { (# s1, w #) -> (# s1, Weak w #) } + +{-| +Dereferences a weak pointer. If the key is still alive, then +@'Just' v@ is returned (where @v@ is the /value/ in the weak pointer), otherwise +'Nothing' is returned. + +The return value of 'deRefWeak' depends on when the garbage collector +runs, hence it is in the 'IO' monad. +-} +deRefWeak :: Weak v -> IO (Maybe v) +deRefWeak (Weak w) = IO $ \s -> + case deRefWeak# w s of + (# s1, flag, p #) -> case flag of + 0# -> (# s1, Nothing #) + _ -> (# s1, Just p #) + +-- | Causes a the finalizer associated with a weak pointer to be run +-- immediately. +finalize :: Weak v -> IO () +finalize (Weak w) = IO $ \s -> + case finalizeWeak# w s of + (# s1, 0#, _ #) -> (# s1, () #) -- already dead, or no finaliser + (# s1, _, f #) -> f s1 + +{- +Instance Eq (Weak v) where + (Weak w1) == (Weak w2) = w1 `sameWeak#` w2 +-} + + +-- run a batch of finalizers from the garbage collector. We're given +-- an array of finalizers and the length of the array, and we just +-- call each one in turn. +-- +-- the IO primitives are inlined by hand here to get the optimal +-- code (sigh) --SDM. + +runFinalizerBatch :: Int -> Array# (IO ()) -> IO () +runFinalizerBatch (I# n) arr = + let go m = IO $ \s -> + case m of + 0# -> (# s, () #) + _ -> let !m' = m -# 1# in + case indexArray# arr m' of { (# io #) -> + case unIO io s of { (# s', _ #) -> + unIO (go m') s' + }} + in + go n + +\end{code} diff --git a/lib/base/src/GHC/Word.hs b/lib/base/src/GHC/Word.hs --- a/lib/base/src/GHC/Word.hs +++ b/lib/base/src/GHC/Word.hs @@ -15,10 +15,6 @@ -- ----------------------------------------------------------------------------- -#define WORD_SIZE_IN_BITS_ (WORD_SIZE# *# 8#) -#define WORD_SIZE_IN_BITS (WORD_SIZE * 8) - - -- #hide module GHC.Word ( Word(..), Word8(..), Word16(..), Word32(..), Word64(..), @@ -29,10 +25,10 @@ import Data.Bits -#if WORD_SIZE < 4 +#if WORD_SIZE_IN_BITS < 32 import GHC.IntWord32 #endif -#if WORD_SIZE < 8 +#if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #endif @@ -43,6 +39,7 @@ import GHC.Read import GHC.Arr import GHC.Show +import GHC.Err ------------------------------------------------------------------------ -- Helper functions @@ -139,7 +136,7 @@ | i# >=# 0# = smallInteger i# | otherwise = wordToInteger x# where - i# = word2Int# x# + !i# = word2Int# x# instance Bounded Word where minBound = 0 @@ -168,7 +165,8 @@ (W# x#) .&. (W# y#) = W# (x# `and#` y#) (W# x#) .|. (W# y#) = W# (x# `or#` y#) (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) - complement (W# x#) = W# (x# `xor#` mb#) where W# mb# = maxBound + complement (W# x#) = W# (x# `xor#` mb#) + where !(W# mb#) = maxBound (W# x#) `shift` (I# i#) | i# >=# 0# = W# (x# `shiftL#` i#) | otherwise = W# (x# `shiftRL#` negateInt# i#) @@ -176,15 +174,11 @@ | i'# ==# 0# = W# x# | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) - wsib = WORD_SIZE_IN_BITS_ {- work around preprocessor problem (??) -} + !i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} bitSize _ = WORD_SIZE_IN_BITS isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Int->Word" fromIntegral = \(I# x#) -> W# (int2Word# x#) "fromIntegral/Word->Int" fromIntegral = \(W# x#) -> I# (word2Int# x#) @@ -271,7 +265,8 @@ (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) - complement (W8# x#) = W8# (x# `xor#` mb#) where W8# mb# = maxBound + complement (W8# x#) = W8# (x# `xor#` mb#) + where !(W8# mb#) = maxBound (W8# x#) `shift` (I# i#) | i# >=# 0# = W8# (narrow8Word# (x# `shiftL#` i#)) | otherwise = W8# (x# `shiftRL#` negateInt# i#) @@ -280,14 +275,10 @@ | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (8# -# i'#)))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) bitSize _ = 8 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8 "fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer @@ -375,7 +366,8 @@ (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) - complement (W16# x#) = W16# (x# `xor#` mb#) where W16# mb# = maxBound + complement (W16# x#) = W16# (x# `xor#` mb#) + where !(W16# mb#) = maxBound (W16# x#) `shift` (I# i#) | i# >=# 0# = W16# (narrow16Word# (x# `shiftL#` i#)) | otherwise = W16# (x# `shiftRL#` negateInt# i#) @@ -384,14 +376,10 @@ | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (16# -# i'#)))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) bitSize _ = 16 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x# "fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16 @@ -491,10 +479,6 @@ bitSize _ = 32 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#)) "fromIntegral/Word->Word32" fromIntegral = \(W# x#) -> W32# (wordToWord32# x#) @@ -577,7 +561,7 @@ | i# >=# 0# = smallInteger i# | otherwise = wordToInteger x# where - i# = word2Int# x# + !i# = word2Int# x# #else = smallInteger (word2Int# x#) #endif @@ -588,7 +572,8 @@ (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) - complement (W32# x#) = W32# (x# `xor#` mb#) where W32# mb# = maxBound + complement (W32# x#) = W32# (x# `xor#` mb#) + where !(W32# mb#) = maxBound (W32# x#) `shift` (I# i#) | i# >=# 0# = W32# (narrow32Word# (x# `shiftL#` i#)) | otherwise = W32# (x# `shiftRL#` negateInt# i#) @@ -597,14 +582,10 @@ | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (32# -# i'#)))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Word32" fromIntegral = \(W8# x#) -> W32# x# "fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x# @@ -727,14 +708,10 @@ | otherwise = W64# ((x# `uncheckedShiftL64#` i'#) `or64#` (x# `uncheckedShiftRL64#` (64# -# i'#))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - -- give the 64-bit shift operations the same treatment as the 32-bit -- ones (see GHC.Base), namely we wrap them in tests to catch the -- cases when we're shifting more than 64 bits to avoid unspecified @@ -817,7 +794,7 @@ | i# >=# 0# = smallInteger i# | otherwise = wordToInteger x# where - i# = word2Int# x# + !i# = word2Int# x# instance Bits Word64 where {-# INLINE shift #-} @@ -825,7 +802,8 @@ (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#) - complement (W64# x#) = W64# (x# `xor#` mb#) where W64# mb# = maxBound + complement (W64# x#) = W64# (x# `xor#` mb#) + where !(W64# mb#) = maxBound (W64# x#) `shift` (I# i#) | i# >=# 0# = W64# (x# `shiftL#` i#) | otherwise = W64# (x# `shiftRL#` negateInt# i#) @@ -834,13 +812,9 @@ | otherwise = W64# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (64# -# i'#))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) + !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 isSigned _ = False - - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) {-# RULES "fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x# diff --git a/lib/base/src/Prelude.hs b/lib/base/src/Prelude.hs --- a/lib/base/src/Prelude.hs +++ b/lib/base/src/Prelude.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Prelude @@ -146,6 +146,7 @@ #ifndef __HUGS__ import Control.Monad import System.IO +import System.IO.Error import Data.List import Data.Either import Data.Maybe @@ -154,18 +155,15 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +-- import GHC.IO +-- import GHC.IO.Exception import Text.Read import GHC.Enum import GHC.Num import GHC.Real import GHC.Float import GHC.Show -import GHC.Err ( error, undefined ) -#endif - -#ifndef __HUGS__ -import qualified Control.Exception.Base as New (catch) +import GHC.Err ( undefined ) #endif #ifdef __HUGS__ @@ -174,12 +172,16 @@ #ifndef __HUGS__ infixr 0 $! +#endif -- ----------------------------------------------------------------------------- -- Miscellaneous functions -- | Strict (call-by-value) application, defined in terms of 'seq'. ($!) :: (a -> b) -> a -> b +#ifdef __GLASGOW_HASKELL__ +f $! x = let !vx = x in f vx -- see #2273 +#elif !defined(__HUGS__) f $! x = x `seq` f x #endif @@ -190,26 +192,3 @@ seq :: a -> b -> b seq _ y = y #endif - -#ifndef __HUGS__ --- | The 'catch' function establishes a handler that receives any 'IOError' --- raised in the action protected by 'catch'. An 'IOError' is caught by --- the most recent handler established by 'catch'. These handlers are --- not selective: all 'IOError's are caught. Exception propagation --- must be explicitly provided in a handler by re-raising any unwanted --- exceptions. For example, in --- --- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e) --- --- the function @f@ returns @[]@ when an end-of-file exception --- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the --- exception is propagated to the next outer handler. --- --- When an exception propagates outside the main program, the Haskell --- system prints the associated 'IOError' value and exits the program. --- --- Non-I\/O exceptions are not caught by this variant; to catch all --- exceptions, use 'Control.Exception.catch' from "Control.Exception". -catch :: IO a -> (IOError -> IO a) -> IO a -catch = New.catch -#endif /* !__HUGS__ */ diff --git a/lib/base/src/Prelude.hs-boot b/lib/base/src/Prelude.hs-boot deleted file mode 100644 --- a/lib/base/src/Prelude.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module Prelude where - -import GHC.IOBase - -catch :: IO a -> (IOError -> IO a) -> IO a diff --git a/lib/base/src/System/Console/GetOpt.hs b/lib/base/src/System/Console/GetOpt.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Console/GetOpt.hs @@ -0,0 +1,393 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Console.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This library provides facilities for parsing the command-line options +-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library. +-- +----------------------------------------------------------------------------- + +{- +Sven Panne Oct. 1996 (small +changes Dec. 1997) + +Two rather obscure features are missing: The Bash 2.0 non-option hack +(if you don't already know it, you probably don't want to hear about +it...) and the recognition of long options with a single dash +(e.g. '-help' is recognised as '--help', as long as there is no short +option 'h'). + +Other differences between GNU's getopt and this implementation: + +* To enforce a coherent description of options and arguments, there + are explanation fields in the option/argument descriptor. + +* Error messages are now more informative, but no longer POSIX + compliant... :-( + +And a final Haskell advertisement: The GNU C implementation uses well +over 1100 lines, we need only 195 here, including a 46 line example! +:-) +-} + +module System.Console.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Examples + + -- |To hopefully illuminate the role of the different data structures, + -- here are the command-line options for a (very simple) compiler, + -- done in two different ways. + -- The difference arises because the type of 'getOpt' is + -- parameterized by the type of values derived from flags. + + -- ** Interpreting flags as concrete values + -- $example1 + + -- ** Interpreting flags as transformations of an options record + -- $example2 +) where + +import Prelude -- necessary to get dependencies right + +import Data.List ( isPrefixOf, find ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr + table = zipWith3 paste (sameLen ss) (sameLen ls) ds + paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z + sameLen xs = flushLeft ((maximum . map length) xs) xs + flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] + +fmtOpt :: OptDescr a -> [(String,String,String)] +fmtOpt (Option sos los ad descr) = + case lines descr of + [] -> [(sosFmt,losFmt,"")] + (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] + where sepBy _ [] = "" + sepBy _ [x] = x + sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs + sosFmt = sepBy ',' (map (fmtShort ad) sos) + losFmt = sepBy ',' (map (fmtLong ad) los) + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad +fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ xs _ _) <- optDescr + , find (p opt) xs /= Nothing ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt y ys rs optDescr = short ads ys rs + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[y] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (UnreqOpt optStr,rest) + short [] xs rest = (UnreqOpt optStr,('-':xs):rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example1 + +A simple choice for the type associated with flags is to define a type +@Flag@ as an algebraic type representing the possible flags and their +arguments: + +> module Opts1 where +> +> import System.Console.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdin" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Then the rest of the program will use the constructed list of flags +to determine it\'s behaviour. + +-} + +{- $example2 + +A different approach is to group the option values in a record of type +@Options@, and have each flag yield a function of type +@Options -> Options@ transforming this record. + +> module Opts2 where +> +> import System.Console.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Options = Options +> { optVerbose :: Bool +> , optShowVersion :: Bool +> , optOutput :: Maybe FilePath +> , optInput :: Maybe FilePath +> , optLibDirs :: [FilePath] +> } deriving Show +> +> defaultOptions = Options +> { optVerbose = False +> , optShowVersion = False +> , optOutput = Nothing +> , optInput = Nothing +> , optLibDirs = [] +> } +> +> options :: [OptDescr (Options -> Options)] +> options = +> [ Option ['v'] ["verbose"] +> (NoArg (\ opts -> opts { optVerbose = True })) +> "chatty output on stderr" +> , Option ['V','?'] ["version"] +> (NoArg (\ opts -> opts { optShowVersion = True })) +> "show version number" +> , Option ['o'] ["output"] +> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") +> "FILE") +> "output FILE" +> , Option ['c'] [] +> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") +> "FILE") +> "input FILE" +> , Option ['L'] ["libdir"] +> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") +> "library directory" +> ] +> +> compilerOpts :: [String] -> IO (Options, [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Similarly, each flag could yield a monadic function transforming a record, +of type @Options -> IO Options@ (or any other monad), allowing option +processing to perform actions of the chosen monad, e.g. printing help or +version messages, checking that file arguments exist, etc. + +-} diff --git a/lib/base/src/System/Environment.hs b/lib/base/src/System/Environment.hs --- a/lib/base/src/System/Environment.hs +++ b/lib/base/src/System/Environment.hs @@ -34,7 +34,8 @@ import Foreign.C import Control.Exception.Base ( bracket ) import Control.Monad -import GHC.IOBase +-- import GHC.IO +import GHC.IO.Exception #endif #ifdef __HUGS__ @@ -123,7 +124,7 @@ if litstring /= nullPtr then peekCString litstring else ioException (IOError Nothing NoSuchThing "getEnv" - "no environment variable" (Just name)) + "no environment variable" Nothing (Just name)) foreign import ccall unsafe "getenv" c_getenv :: CString -> IO (Ptr CChar) @@ -154,7 +155,8 @@ pName <- System.Environment.getProgName existing_args <- System.Environment.getArgs bracket (setArgs new_args) - (\argv -> do setArgs (pName:existing_args); freeArgv argv) + (\argv -> do _ <- setArgs (pName:existing_args) + freeArgv argv) (const act) freeArgv :: Ptr CString -> IO () diff --git a/lib/base/src/System/Exit.hs b/lib/base/src/System/Exit.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Exit.hs @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Exit +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Exiting the program. +-- +----------------------------------------------------------------------------- + +module System.Exit + ( + ExitCode(ExitSuccess,ExitFailure) + , exitWith -- :: ExitCode -> IO a + , exitFailure -- :: IO a + , exitSuccess -- :: IO a + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.IO +import GHC.IO.Exception +#endif + +#ifdef __HUGS__ +import Hugs.Prelude (ExitCode(..)) +import Control.Exception.Base +#endif + +#ifdef __NHC__ +import System + ( ExitCode(..) + , exitWith + ) +#endif + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. Before the program terminates, any open or +-- semi-closed handles are first closed. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as it it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses +-- the error handling in the 'IO' monad and cannot be intercepted by +-- 'catch' from the "Prelude". However it is a 'SomeException', and can +-- be caught using the functions of "Control.Exception". This means +-- that cleanup computations added with 'Control.Exception.bracket' +-- (from "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitException' as normal, but the +-- exception will not cause the process itself to exit. +-- +#ifndef __NHC__ +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throwIO ExitSuccess +exitWith code@(ExitFailure n) + | n /= 0 = throwIO code +#ifdef __GLASGOW_HASKELL__ + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) +#endif +#endif /* ! __NHC__ */ + +-- | The computation 'exitFailure' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +-- | The computation 'exitSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- sucessfully. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess diff --git a/lib/base/src/System/IO.hs b/lib/base/src/System/IO.hs --- a/lib/base/src/System/IO.hs +++ b/lib/base/src/System/IO.hs @@ -159,6 +159,65 @@ openTempFile, openBinaryTempFile, + openTempFileWithDefaultPermissions, + openBinaryTempFileWithDefaultPermissions, + +#if !defined(__NHC__) && !defined(__HUGS__) + -- * Unicode encoding\/decoding + + -- | A text-mode 'Handle' has an associated 'TextEncoding', which + -- is used to decode bytes into Unicode characters when reading, + -- and encode Unicode characters into bytes when writing. + -- + -- The default 'TextEncoding' is the same as the default encoding + -- on your system, which is also available as 'localeEncoding'. + -- (GHC note: on Windows, we currently do not support double-byte + -- encodings; if the console\'s code page is unsupported, then + -- 'localeEncoding' will be 'latin1'.) + -- + -- Encoding and decoding errors are always detected and reported, + -- except during lazy I/O ('hGetContents', 'getContents', and + -- 'readFile'), where a decoding error merely results in + -- termination of the character stream, as with other I/O errors. + + hSetEncoding, + hGetEncoding, + + -- ** Unicode encodings + TextEncoding, + latin1, + utf8, utf8_bom, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding, + mkTextEncoding, +#endif + +#if !defined(__NHC__) && !defined(__HUGS__) + -- * Newline conversion + + -- | In Haskell, a newline is always represented by the character + -- '\n'. However, in files and external character streams, a + -- newline may be represented by another character sequence, such + -- as '\r\n'. + -- + -- A text-mode 'Handle' has an associated 'NewlineMode' that + -- specifies how to transate newline characters. The + -- 'NewlineMode' specifies the input and output translation + -- separately, so that for instance you can translate '\r\n' + -- to '\n' on input, but leave newlines as '\n' on output. + -- + -- The default 'NewlineMode' for a 'Handle' is + -- 'nativeNewlineMode', which does no translation on Unix systems, + -- but translates '\r\n' to '\n' and back on Windows. + -- + -- Binary-mode 'Handle's do no newline translation at all. + -- + hSetNewlineMode, + Newline(..), nativeNewline, + NewlineMode(..), + noNewlineTranslation, universalNewlineMode, nativeNewlineMode, +#endif ) where import Control.Exception.Base @@ -168,17 +227,22 @@ import Data.List import Data.Maybe import Foreign.C.Error -import Foreign.C.String import Foreign.C.Types import System.Posix.Internals +import System.Posix.Types #endif #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase -- Together these four Prelude modules define -import GHC.Handle -- all the stuff exported by IO for the GHC version -import GHC.IO -import GHC.Exception +import GHC.Real +import GHC.IO hiding ( onException ) +import GHC.IO.IOMode +import GHC.IO.Handle.FD +import qualified GHC.IO.FD as FD +import GHC.IO.Handle +import GHC.IORef +import GHC.IO.Exception ( userError ) +import GHC.IO.Encoding import GHC.Num import Text.Read import GHC.Show @@ -406,6 +470,8 @@ -- Assume a unix platform, where text and binary I/O are identical. openBinaryFile = openFile hSetBinaryMode _ _ = return () + +type CMode = Int #endif -- | The function creates a temporary file in ReadWrite mode. @@ -428,14 +494,29 @@ -- the created file will be \"fooXXX.ext\" where XXX is some -- random number. -> IO (FilePath, Handle) -openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False +openTempFile tmp_dir template + = openTempFile' "openTempFile" tmp_dir template False 0o600 -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True +openBinaryTempFile tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 -openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle) -openTempFile' loc tmp_dir template binary = do +-- | Like 'openTempFile', but uses the default file permissions +openTempFileWithDefaultPermissions :: FilePath -> String + -> IO (FilePath, Handle) +openTempFileWithDefaultPermissions tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template False 0o666 + +-- | Like 'openBinaryTempFile', but uses the default file permissions +openBinaryTempFileWithDefaultPermissions :: FilePath -> String + -> IO (FilePath, Handle) +openBinaryTempFileWithDefaultPermissions tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template True 0o666 + +openTempFile' :: String -> FilePath -> String -> Bool -> CMode + -> IO (FilePath, Handle) +openTempFile' loc tmp_dir template binary mode = do pid <- c_getpid findTempName pid where @@ -466,13 +547,13 @@ oflags = oflags1 .|. binary_flags #endif -#ifdef __NHC__ +#if defined(__NHC__) findTempName x = do h <- openFile filepath ReadWriteMode return (filepath, h) -#else +#elif defined(__GLASGOW_HASKELL__) findTempName x = do - fd <- withCString filepath $ \ f -> - c_open f oflags 0o600 + fd <- withFilePath filepath $ \ f -> + c_open f oflags mode if fd < 0 then do errno <- getErrno @@ -480,12 +561,20 @@ then findTempName (x+1) else ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) else do - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently + + (fD,fd_type) <- FD.mkFD (fromIntegral fd) ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} + (Just localeEncoding) + + return (filepath, h) +#else h <- fdToHandle fd `onException` c_close fd return (filepath, h) #endif + where filename = prefix ++ show x ++ suffix filepath = tmp_dir `combine` filename diff --git a/lib/base/src/System/IO/Error.hs b/lib/base/src/System/IO/Error.hs --- a/lib/base/src/System/IO/Error.hs +++ b/lib/base/src/System/IO/Error.hs @@ -21,13 +21,11 @@ userError, -- :: String -> IOError -#ifndef __NHC__ mkIOError, -- :: IOErrorType -> String -> Maybe Handle -- -> Maybe FilePath -> IOError annotateIOError, -- :: IOError -> String -> Maybe Handle -- -> Maybe FilePath -> IOError -#endif -- ** Classifying I\/O errors isAlreadyExistsError, -- :: IOError -> Bool @@ -40,21 +38,17 @@ isUserError, -- ** Attributes of I\/O errors -#ifndef __NHC__ ioeGetErrorType, -- :: IOError -> IOErrorType ioeGetLocation, -- :: IOError -> String -#endif ioeGetErrorString, -- :: IOError -> String ioeGetHandle, -- :: IOError -> Maybe Handle ioeGetFileName, -- :: IOError -> Maybe FilePath -#ifndef __NHC__ ioeSetErrorType, -- :: IOError -> IOErrorType -> IOError ioeSetErrorString, -- :: IOError -> String -> IOError ioeSetLocation, -- :: IOError -> String -> IOError ioeSetHandle, -- :: IOError -> Handle -> IOError ioeSetFileName, -- :: IOError -> FilePath -> IOError -#endif -- * Types of I\/O error IOErrorType, -- abstract @@ -85,22 +79,23 @@ catch, -- :: IO a -> (IOError -> IO a) -> IO a try, -- :: IO a -> IO (Either IOError a) -#ifndef __NHC__ modifyIOError, -- :: (IOError -> IOError) -> IO a -> IO a -#endif ) where #ifndef __HUGS__ +import qualified Control.Exception.Base as New (catch) +#endif + +#ifndef __HUGS__ import Data.Either #endif import Data.Maybe #ifdef __GLASGOW_HASKELL__ -import {-# SOURCE #-} Prelude (catch) -import qualified Control.Exception.Base as New - import GHC.Base -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Handle.Types import Text.Show #endif @@ -111,6 +106,7 @@ #ifdef __NHC__ import IO ( IOError () + , Handle () , try , ioError , userError @@ -126,8 +122,10 @@ , ioeGetHandle -- :: IOError -> Maybe Handle , ioeGetFileName -- :: IOError -> Maybe FilePath ) ---import Data.Maybe (fromJust) ---import Control.Monad (MonadPlus(mplus)) +import qualified NHC.Internal as NHC (IOError(..)) +import qualified NHC.DErrNo as NHC (ErrNo(..)) +import Data.Maybe (fromJust) +import Control.Monad (MonadPlus(mplus)) #endif -- | The construct 'try' @comp@ exposes IO errors which occur within a @@ -156,25 +154,28 @@ IOError{ ioe_type = t, ioe_location = location, ioe_description = "", +#if defined(__GLASGOW_HASKELL__) + ioe_errno = Nothing, +#endif ioe_handle = maybe_hdl, ioe_filename = maybe_filename } +#endif /* __GLASGOW_HASKELL__ || __HUGS__ */ #ifdef __NHC__ mkIOError EOF location maybe_hdl maybe_filename = - EOFError location (fromJust maybe_hdl) + NHC.EOFError location (fromJust maybe_hdl) mkIOError UserError location maybe_hdl maybe_filename = - UserError location "" + NHC.UserError location "" mkIOError t location maybe_hdl maybe_filename = - NHC.FFI.mkIOError location maybe_filename maybe_handle (ioeTypeToInt t) + NHC.IOError location maybe_filename maybe_hdl (ioeTypeToErrNo t) where - ioeTypeToInt AlreadyExists = fromEnum EEXIST - ioeTypeToInt NoSuchThing = fromEnum ENOENT - ioeTypeToInt ResourceBusy = fromEnum EBUSY - ioeTypeToInt ResourceExhausted = fromEnum ENOSPC - ioeTypeToInt IllegalOperation = fromEnum EPERM - ioeTypeToInt PermissionDenied = fromEnum EACCES -#endif -#endif /* __GLASGOW_HASKELL__ || __HUGS__ */ + ioeTypeToErrNo AlreadyExists = NHC.EEXIST + ioeTypeToErrNo NoSuchThing = NHC.ENOENT + ioeTypeToErrNo ResourceBusy = NHC.EBUSY + ioeTypeToErrNo ResourceExhausted = NHC.ENOSPC + ioeTypeToErrNo IllegalOperation = NHC.EPERM + ioeTypeToErrNo PermissionDenied = NHC.EACCES +#endif /* __NHC__ */ #ifndef __NHC__ -- ----------------------------------------------------------------------------- @@ -355,6 +356,47 @@ ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl } ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename } +#elif defined(__NHC__) +ioeGetErrorType :: IOError -> IOErrorType +ioeGetLocation :: IOError -> String + +ioeGetErrorType e | isAlreadyExistsError e = AlreadyExists + | isDoesNotExistError e = NoSuchThing + | isAlreadyInUseError e = ResourceBusy + | isFullError e = ResourceExhausted + | isEOFError e = EOF + | isIllegalOperation e = IllegalOperation + | isPermissionError e = PermissionDenied + | isUserError e = UserError + +ioeGetLocation (NHC.IOError _ _ _ _) = "unknown location" +ioeGetLocation (NHC.EOFError _ _ ) = "unknown location" +ioeGetLocation (NHC.PatternError loc) = loc +ioeGetLocation (NHC.UserError loc _) = loc + +ioeSetErrorType :: IOError -> IOErrorType -> IOError +ioeSetErrorString :: IOError -> String -> IOError +ioeSetLocation :: IOError -> String -> IOError +ioeSetHandle :: IOError -> Handle -> IOError +ioeSetFileName :: IOError -> FilePath -> IOError + +ioeSetErrorType e _ = e +ioeSetErrorString (NHC.IOError _ f h e) s = NHC.IOError s f h e +ioeSetErrorString (NHC.EOFError _ f) s = NHC.EOFError s f +ioeSetErrorString e@(NHC.PatternError _) _ = e +ioeSetErrorString (NHC.UserError l _) s = NHC.UserError l s +ioeSetLocation e@(NHC.IOError _ _ _ _) _ = e +ioeSetLocation e@(NHC.EOFError _ _) _ = e +ioeSetLocation (NHC.PatternError _) l = NHC.PatternError l +ioeSetLocation (NHC.UserError _ m) l = NHC.UserError l m +ioeSetHandle (NHC.IOError o f _ e) h = NHC.IOError o f (Just h) e +ioeSetHandle (NHC.EOFError o _) h = NHC.EOFError o h +ioeSetHandle e@(NHC.PatternError _) _ = e +ioeSetHandle e@(NHC.UserError _ _) _ = e +ioeSetFileName (NHC.IOError o _ h e) f = NHC.IOError o (Just f) h e +ioeSetFileName e _ = e +#endif + -- | Catch any 'IOError' that occurs in the computation and throw a -- modified version. modifyIOError :: (IOError -> IOError) -> IO a -> IO a @@ -371,20 +413,46 @@ -> Maybe Handle -> Maybe FilePath -> IOError -annotateIOError (IOError ohdl errTy _ str opath) loc hdl path = - IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath) + +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +annotateIOError ioe loc hdl path = + ioe{ ioe_handle = hdl `mplus` ioe_handle ioe, + ioe_location = loc, ioe_filename = path `mplus` ioe_filename ioe } where Nothing `mplus` ys = ys xs `mplus` _ = xs #endif /* __GLASGOW_HASKELL__ || __HUGS__ */ -#if 0 /*__NHC__*/ -annotateIOError (IOError msg file hdl code) msg' file' hdl' = - IOError (msg++'\n':msg') (file`mplus`file') (hdl`mplus`hdl') code -annotateIOError (EOFError msg hdl) msg' file' hdl' = - EOFError (msg++'\n':msg') (hdl`mplus`hdl') -annotateIOError (UserError loc msg) msg' file' hdl' = - UserError loc (msg++'\n':msg') -annotateIOError (PatternError loc) msg' file' hdl' = - PatternError (loc++'\n':msg') +#if defined(__NHC__) +annotateIOError (NHC.IOError msg file hdl code) msg' hdl' file' = + NHC.IOError (msg++'\n':msg') (file`mplus`file') (hdl`mplus`hdl') code +annotateIOError (NHC.EOFError msg hdl) msg' _ _ = + NHC.EOFError (msg++'\n':msg') hdl +annotateIOError (NHC.UserError loc msg) msg' _ _ = + NHC.UserError loc (msg++'\n':msg') +annotateIOError (NHC.PatternError loc) msg' _ _ = + NHC.PatternError (loc++'\n':msg') #endif + +#ifndef __HUGS__ +-- | The 'catch' function establishes a handler that receives any 'IOError' +-- raised in the action protected by 'catch'. An 'IOError' is caught by +-- the most recent handler established by 'catch'. These handlers are +-- not selective: all 'IOError's are caught. Exception propagation +-- must be explicitly provided in a handler by re-raising any unwanted +-- exceptions. For example, in +-- +-- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e) +-- +-- the function @f@ returns @[]@ when an end-of-file exception +-- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the +-- exception is propagated to the next outer handler. +-- +-- When an exception propagates outside the main program, the Haskell +-- system prints the associated 'IOError' value and exits the program. +-- +-- Non-I\/O exceptions are not caught by this variant; to catch all +-- exceptions, use 'Control.Exception.catch' from "Control.Exception". +catch :: IO a -> (IOError -> IO a) -> IO a +catch = New.catch +#endif /* !__HUGS__ */ diff --git a/lib/base/src/System/IO/Unsafe.hs b/lib/base/src/System/IO/Unsafe.hs --- a/lib/base/src/System/IO/Unsafe.hs +++ b/lib/base/src/System/IO/Unsafe.hs @@ -20,7 +20,7 @@ ) where #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase (unsafePerformIO, unsafeInterleaveIO) +import GHC.IO (unsafePerformIO, unsafeInterleaveIO) #endif #ifdef __HUGS__ @@ -28,10 +28,6 @@ #endif #ifdef __NHC__ -import NHC.Internal (unsafePerformIO) +import NHC.Internal (unsafePerformIO, unsafeInterleaveIO) #endif -#if !__GLASGOW_HASKELL__ && !__HUGS__ -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO f = return (unsafePerformIO f) -#endif diff --git a/lib/base/src/System/Info.hs b/lib/base/src/System/Info.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Info.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Info +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Information about the characteristics of the host +-- system lucky enough to run your program. +-- +----------------------------------------------------------------------------- + +module System.Info + ( + os, -- :: String + arch, -- :: String + compilerName, -- :: String + compilerVersion -- :: Version + ) where + +import Prelude +import Data.Version + +-- | The version of 'compilerName' with which the program was compiled +-- or is being interpreted. +compilerVersion :: Version +compilerVersion = Version {versionBranch=[major, minor], versionTags=[]} + where (major, minor) = compilerVersionRaw `divMod` 100 + +-- | The operating system on which the program is running. +os :: String + +-- | The machine architecture on which the program is running. +arch :: String + +-- | The Haskell implementation with which the program was compiled +-- or is being interpreted. +compilerName :: String + +compilerVersionRaw :: Int + +#if defined(__NHC__) +#include "OSInfo.hs" +compilerName = "nhc98" +compilerVersionRaw = __NHC__ + +#elif defined(__LHC__) +compilerName = "lhc" +compilerVersionRaw = 0 + +#elif defined(__GLASGOW_HASKELL__) +#include "ghcplatform.h" +os = HOST_OS +arch = HOST_ARCH +compilerName = "ghc" +compilerVersionRaw = __GLASGOW_HASKELL__ + +#elif defined(__HUGS__) +#include "platform.h" +os = HOST_OS +arch = HOST_ARCH +compilerName = "hugs" +compilerVersionRaw = 0 -- ToDo + +#else +#error Unknown compiler name +#endif diff --git a/lib/base/src/System/Mem.hs b/lib/base/src/System/Mem.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Mem.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Memory-related system things. +-- +----------------------------------------------------------------------------- + +module System.Mem ( + performGC -- :: IO () + ) where + +import Prelude + +#ifdef __HUGS__ +import Hugs.IOExts +#endif + +#ifdef __GLASGOW_HASKELL__ +-- | Triggers an immediate garbage collection +foreign import ccall {-safe-} "performMajorGC" performGC :: IO () +#endif + +#ifdef __NHC__ +import NHC.IOExtras (performGC) +#endif diff --git a/lib/base/src/System/Mem/StableName.hs b/lib/base/src/System/Mem/StableName.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Mem/StableName.hs @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem.StableName +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Stable names are a way of performing fast (O(1)), not-quite-exact +-- comparison between objects. +-- +-- Stable names solve the following problem: suppose you want to build +-- a hash table with Haskell objects as keys, but you want to use +-- pointer equality for comparison; maybe because the keys are large +-- and hashing would be slow, or perhaps because the keys are infinite +-- in size. We can\'t build a hash table using the address of the +-- object as the key, because objects get moved around by the garbage +-- collector, meaning a re-hash would be necessary after every garbage +-- collection. +-- +------------------------------------------------------------------------------- + +module System.Mem.StableName ( + -- * Stable Names + StableName, + makeStableName, + hashStableName, + ) where + +import Prelude + +import Data.Typeable + +#ifdef __HUGS__ +import Hugs.Stable +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.IO ( IO(..) ) +import GHC.Base ( Int(..), StableName#, makeStableName# + , eqStableName#, stableNameToInt# ) + +----------------------------------------------------------------------------- +-- Stable Names + +{-| + An abstract name for an object, that supports equality and hashing. + + Stable names have the following property: + + * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ + then @sn1@ and @sn2@ were created by calls to @makeStableName@ on + the same object. + + The reverse is not necessarily true: if two stable names are not + equal, then the objects they name may still be equal. Note in particular + that `mkStableName` may return a different `StableName` after an + object is evaluated. + + Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), + but differ in the following ways: + + * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. + Stable names are reclaimed by the runtime system when they are no + longer needed. + + * There is no @deRefStableName@ operation. You can\'t get back from + a stable name to the original Haskell object. The reason for + this is that the existence of a stable name for an object does not + guarantee the existence of the object itself; it can still be garbage + collected. +-} + +data StableName a = StableName (StableName# a) + + +-- | Makes a 'StableName' for an arbitrary object. The object passed as +-- the first argument is not evaluated by 'makeStableName'. +makeStableName :: a -> IO (StableName a) +#if defined(__PARALLEL_HASKELL__) +makeStableName a = + error "makeStableName not implemented in parallel Haskell" +#else +makeStableName a = IO $ \ s -> + case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) +#endif + +-- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not +-- necessarily unique; several 'StableName's may map to the same 'Int' +-- (in practice however, the chances of this are small, so the result +-- of 'hashStableName' makes a good hash key). +hashStableName :: StableName a -> Int +#if defined(__PARALLEL_HASKELL__) +hashStableName (StableName sn) = + error "hashStableName not implemented in parallel Haskell" +#else +hashStableName (StableName sn) = I# (stableNameToInt# sn) +#endif + +instance Eq (StableName a) where +#if defined(__PARALLEL_HASKELL__) + (StableName sn1) == (StableName sn2) = + error "eqStableName not implemented in parallel Haskell" +#else + (StableName sn1) == (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True +#endif + +#endif /* __GLASGOW_HASKELL__ */ + +#include "Typeable.h" +INSTANCE_TYPEABLE1(StableName,stableNameTc,"StableName") diff --git a/lib/base/src/System/Mem/Weak.hs b/lib/base/src/System/Mem/Weak.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Mem/Weak.hs @@ -0,0 +1,151 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem.Weak +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- In general terms, a weak pointer is a reference to an object that is +-- not followed by the garbage collector - that is, the existence of a +-- weak pointer to an object has no effect on the lifetime of that +-- object. A weak pointer can be de-referenced to find out +-- whether the object it refers to is still alive or not, and if so +-- to return the object itself. +-- +-- Weak pointers are particularly useful for caches and memo tables. +-- To build a memo table, you build a data structure +-- mapping from the function argument (the key) to its result (the +-- value). When you apply the function to a new argument you first +-- check whether the key\/value pair is already in the memo table. +-- The key point is that the memo table itself should not keep the +-- key and value alive. So the table should contain a weak pointer +-- to the key, not an ordinary pointer. The pointer to the value must +-- not be weak, because the only reference to the value might indeed be +-- from the memo table. +-- +-- So it looks as if the memo table will keep all its values +-- alive for ever. One way to solve this is to purge the table +-- occasionally, by deleting entries whose keys have died. +-- +-- The weak pointers in this library +-- support another approach, called /finalization/. +-- When the key referred to by a weak pointer dies, the storage manager +-- arranges to run a programmer-specified finalizer. In the case of memo +-- tables, for example, the finalizer could remove the key\/value pair +-- from the memo table. +-- +-- Another difficulty with the memo table is that the value of a +-- key\/value pair might itself contain a pointer to the key. +-- So the memo table keeps the value alive, which keeps the key alive, +-- even though there may be no other references to the key so both should +-- die. The weak pointers in this library provide a slight +-- generalisation of the basic weak-pointer idea, in which each +-- weak pointer actually contains both a key and a value. +-- +----------------------------------------------------------------------------- + +module System.Mem.Weak ( + -- * The @Weak@ type + Weak, -- abstract + + -- * The general interface + mkWeak, -- :: k -> v -> Maybe (IO ()) -> IO (Weak v) + deRefWeak, -- :: Weak v -> IO (Maybe v) + finalize, -- :: Weak v -> IO () + + -- * Specialised versions + mkWeakPtr, -- :: k -> Maybe (IO ()) -> IO (Weak k) + addFinalizer, -- :: key -> IO () -> IO () + mkWeakPair, -- :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v)) + -- replaceFinaliser -- :: Weak v -> IO () -> IO () + + -- * A precise semantics + + -- $precise + ) where + +import Prelude + +#ifdef __HUGS__ +import Hugs.Weak +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Weak +#endif + +-- | A specialised version of 'mkWeak', where the key and the value are +-- the same object: +-- +-- > mkWeakPtr key finalizer = mkWeak key key finalizer +-- +mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k) +mkWeakPtr key finalizer = mkWeak key key finalizer + +{-| + A specialised version of 'mkWeakPtr', where the 'Weak' object + returned is simply thrown away (however the finalizer will be + remembered by the garbage collector, and will still be run + when the key becomes unreachable). + + Note: adding a finalizer to a 'Foreign.ForeignPtr.ForeignPtr' using + 'addFinalizer' won't work as well as using the specialised version + 'Foreign.ForeignPtr.addForeignPtrFinalizer' because the latter + version adds the finalizer to the primitive 'ForeignPtr#' object + inside, whereas the generic 'addFinalizer' will add the finalizer to + the box. Optimisations tend to remove the box, which may cause the + finalizer to run earlier than you intended. The same motivation + justifies the existence of + 'Control.Concurrent.MVar.addMVarFinalizer' and + 'Data.IORef.mkWeakIORef' (the non-uniformity is accidental). +-} +addFinalizer :: key -> IO () -> IO () +addFinalizer key finalizer = do + _ <- mkWeakPtr key (Just finalizer) -- throw it away + return () + +-- | A specialised version of 'mkWeak' where the value is actually a pair +-- of the key and value passed to 'mkWeakPair': +-- +-- > mkWeakPair key val finalizer = mkWeak key (key,val) finalizer +-- +-- The advantage of this is that the key can be retrieved by 'deRefWeak' +-- in addition to the value. +mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v)) +mkWeakPair key val finalizer = mkWeak key (key,val) finalizer + + +{- $precise + +The above informal specification is fine for simple situations, but +matters can get complicated. In particular, it needs to be clear +exactly when a key dies, so that any weak pointers that refer to it +can be finalized. Suppose, for example, the value of one weak pointer +refers to the key of another...does that keep the key alive? + +The behaviour is simply this: + + * If a weak pointer (object) refers to an /unreachable/ + key, it may be finalized. + + * Finalization means (a) arrange that subsequent calls + to 'deRefWeak' return 'Nothing'; and (b) run the finalizer. + +This behaviour depends on what it means for a key to be reachable. +Informally, something is reachable if it can be reached by following +ordinary pointers from the root set, but not following weak pointers. +We define reachability more precisely as follows A heap object is +reachable if: + + * It is a member of the /root set/. + + * It is directly pointed to by a reachable object, other than + a weak pointer object. + + * It is a weak pointer object whose key is reachable. + + * It is the value or finalizer of an object whose key is reachable. +-} diff --git a/lib/base/src/System/Posix/Internals.hs b/lib/base/src/System/Posix/Internals.hs --- a/lib/base/src/System/Posix/Internals.hs +++ b/lib/base/src/System/Posix/Internals.hs @@ -23,7 +23,14 @@ -- #hide module System.Posix.Internals where +#ifdef __NHC__ +#define HTYPE_TCFLAG_T +#endif +#ifdef __LHC__ +#define HTYPE_TCFLAG_T +#endif + #if ! (defined(mingw32_HOST_OS) || defined(__MINGW32__)) import Control.Monad #endif @@ -32,30 +39,38 @@ import Foreign import Foreign.C -import Data.Bits +-- import Data.Bits import Data.Maybe +#if !defined(HTYPE_TCFLAG_T) +import System.IO.Error +#endif + #if __GLASGOW_HASKELL__ import GHC.Base import GHC.Num import GHC.Real -import GHC.IOBase +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Exception +import GHC.IO.Device #elif __HUGS__ import Hugs.Prelude (IOException(..), IOErrorType(..)) import Hugs.IO (IOMode(..)) -#else +#elif __NHC__ +import GHC.IO.Device -- yes, I know, but its portable, really! import System.IO +import Control.Exception +import DIOError #endif #ifdef __HUGS__ -{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-} +{-# CFILES cbits/PrelIOUtils.c cbits/consUtils.c #-} #endif -- --------------------------------------------------------------------------- -- Types -type CDir = () -type CDirent = () type CFLock = () type CGroup = () type CLconv = () @@ -69,9 +84,7 @@ type CUtimbuf = () type CUtsname = () -#ifndef __GLASGOW_HASKELL__ type FD = CInt -#endif -- --------------------------------------------------------------------------- -- stat()-related stuff @@ -79,42 +92,39 @@ fdFileSize :: FD -> IO Integer fdFileSize fd = allocaBytes sizeof_stat $ \ p_stat -> do - throwErrnoIfMinus1Retry "fileSize" $ + throwErrnoIfMinus1Retry_ "fileSize" $ c_fstat fd p_stat c_mode <- st_mode p_stat :: IO CMode if not (s_isreg c_mode) then return (-1) else do - c_size <- st_size p_stat - return (fromIntegral c_size) - -data FDType = Directory | Stream | RegularFile | RawDevice - deriving (Eq) + c_size <- st_size p_stat + return (fromIntegral c_size) -fileType :: FilePath -> IO FDType +fileType :: FilePath -> IO IODeviceType fileType file = allocaBytes sizeof_stat $ \ p_stat -> do - withCString file $ \p_file -> do - throwErrnoIfMinus1Retry "fileType" $ + withFilePath file $ \p_file -> do + throwErrnoIfMinus1Retry_ "fileType" $ c_stat p_file p_stat statGetType p_stat -- NOTE: On Win32 platforms, this will only work with file descriptors -- referring to file handles. i.e., it'll fail for socket FDs. -fdStat :: FD -> IO (FDType, CDev, CIno) +fdStat :: FD -> IO (IODeviceType, CDev, CIno) fdStat fd = allocaBytes sizeof_stat $ \ p_stat -> do - throwErrnoIfMinus1Retry "fdType" $ + throwErrnoIfMinus1Retry_ "fdType" $ c_fstat fd p_stat ty <- statGetType p_stat dev <- st_dev p_stat ino <- st_ino p_stat return (ty,dev,ino) -fdType :: FD -> IO FDType +fdType :: FD -> IO IODeviceType fdType fd = do (ty,_,_) <- fdStat fd; return ty -statGetType :: Ptr CStat -> IO FDType +statGetType :: Ptr CStat -> IO IODeviceType statGetType p_stat = do c_mode <- st_mode p_stat :: IO CMode case () of @@ -127,17 +137,15 @@ | otherwise -> ioError ioe_unknownfiletype ioe_unknownfiletype :: IOException +#ifndef __NHC__ ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType" - "unknown file type" Nothing - -#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__)) -closeFd :: Bool -> CInt -> IO CInt -closeFd isStream fd - | isStream = c_closesocket fd - | otherwise = c_close fd - -foreign import stdcall unsafe "HsBase.h closesocket" - c_closesocket :: CInt -> IO CInt + "unknown file type" +# if __GLASGOW_HASKELL__ + Nothing +# endif + Nothing +#else +ioe_unknownfiletype = UserError "fdType" "unknown file type" #endif fdGetMode :: FD -> IO IOMode @@ -164,12 +172,17 @@ return mode +#ifdef mingw32_HOST_OS +withFilePath :: FilePath -> (CWString -> IO a) -> IO a +withFilePath = withCWString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + -- --------------------------------------------------------------------------- -- Terminal-related stuff -fdIsTTY :: FD -> IO Bool -fdIsTTY fd = c_isatty fd >>= return.toBool - #if defined(HTYPE_TCFLAG_T) setEcho :: FD -> Bool -> IO () @@ -208,7 +221,7 @@ tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a tcSetAttr fd fun = do allocaBytes sizeof_termios $ \p_tios -> do - throwErrnoIfMinus1Retry "tcSetAttr" + throwErrnoIfMinus1Retry_ "tcSetAttr" (c_tcgetattr fd p_tios) #ifdef __GLASGOW_HASKELL__ @@ -228,14 +241,18 @@ -- wrapper which temporarily blocks SIGTTOU around the call, making it -- transparent. allocaBytes sizeof_sigset_t $ \ p_sigset -> do - allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do - c_sigemptyset p_sigset - c_sigaddset p_sigset const_sigttou - c_sigprocmask const_sig_block p_sigset p_old_sigset + allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do + throwErrnoIfMinus1_ "sigemptyset" $ + c_sigemptyset p_sigset + throwErrnoIfMinus1_ "sigaddset" $ + c_sigaddset p_sigset const_sigttou + throwErrnoIfMinus1_ "sigprocmask" $ + c_sigprocmask const_sig_block p_sigset p_old_sigset r <- fun p_tios -- do the business - throwErrnoIfMinus1Retry_ "tcSetAttr" $ - c_tcsetattr fd const_tcsanow p_tios - c_sigprocmask const_sig_setmask p_old_sigset nullPtr + --throwErrnoIfMinus1Retry_ "tcSetAttr" $ + -- c_tcsetattr fd const_tcsanow p_tios + throwErrnoIfMinus1_ "sigprocmask" $ + c_sigprocmask const_sig_setmask p_old_sigset nullPtr return r #ifdef __GLASGOW_HASKELL__ @@ -265,7 +282,11 @@ ioe_unk_error :: String -> String -> IOException ioe_unk_error loc msg - = IOError Nothing OtherError loc msg Nothing +#ifndef __NHC__ + = ioeSetErrorString (mkIOError OtherError loc Nothing Nothing) msg +#else + = UserError loc msg +#endif -- Note: echoing goes hand in hand with enabling 'line input' / raw-ness -- for Win32 consoles, hence setEcho ends up being the inverse of setCooked. @@ -297,21 +318,23 @@ -- --------------------------------------------------------------------------- -- Turning on non-blocking for a file descriptor -setNonBlockingFD :: FD -> IO () +setNonBlockingFD :: FD -> Bool -> IO () #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) -setNonBlockingFD fd = do +setNonBlockingFD fd set = do flags <- throwErrnoIfMinus1Retry "setNonBlockingFD" (c_fcntl_read fd const_f_getfl) - -- An error when setting O_NONBLOCK isn't fatal: on some systems - -- there are certain file handles on which this will fail (eg. /dev/null - -- on FreeBSD) so we throw away the return code from fcntl_write. - unless (testBit flags (fromIntegral o_NONBLOCK)) $ do - c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK)) + let flags' | set = flags .|. o_NONBLOCK + | otherwise = flags .&. complement o_NONBLOCK + unless (flags == flags') $ do + -- An error when setting O_NONBLOCK isn't fatal: on some systems + -- there are certain file handles on which this will fail (eg. /dev/null + -- on FreeBSD) so we throw away the return code from fcntl_write. + _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags') return () #else -- bogus defns for win32 -setNonBlockingFD _ = return () +setNonBlockingFD _ _ = return () #endif @@ -321,14 +344,19 @@ #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) setCloseOnExec :: FD -> IO () setCloseOnExec fd = do - throwErrnoIfMinus1 "setCloseOnExec" $ + throwErrnoIfMinus1_ "setCloseOnExec" $ c_fcntl_write fd const_f_setfd const_fd_cloexec - return () #endif -- ----------------------------------------------------------------------------- -- foreign imports +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +type CFilePath = CString +#else +type CFilePath = CWString +#endif + foreign import ccall unsafe "HsBase.h access" c_access :: CString -> CInt -> IO CInt @@ -338,9 +366,6 @@ foreign import ccall unsafe "HsBase.h close" c_close :: CInt -> IO CInt -foreign import ccall unsafe "HsBase.h closedir" - c_closedir :: Ptr CDir -> IO CInt - foreign import ccall unsafe "HsBase.h creat" c_creat :: CString -> CMode -> IO CInt @@ -350,7 +375,7 @@ foreign import ccall unsafe "HsBase.h dup2" c_dup2 :: CInt -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h __hscore_fstat" +foreign import ccall unsafe "fstat" c_fstat :: CInt -> Ptr CStat -> IO CInt foreign import ccall unsafe "HsBase.h isatty" @@ -360,37 +385,34 @@ foreign import ccall unsafe "HsBase.h __hscore_lseek" c_lseek :: CInt -> Int64 -> CInt -> IO Int64 #else -foreign import ccall unsafe "HsBase.h __hscore_lseek" +foreign import ccall unsafe "lseek" c_lseek :: CInt -> COff -> CInt -> IO COff #endif -foreign import ccall unsafe "HsBase.h __hscore_lstat" - lstat :: CString -> Ptr CStat -> IO CInt +foreign import ccall unsafe "lstat" + lstat :: CFilePath -> Ptr CStat -> IO CInt foreign import ccall unsafe "HsBase.h __hscore_open" - c_open :: CString -> CInt -> CMode -> IO CInt - -foreign import ccall unsafe "HsBase.h opendir" - c_opendir :: CString -> IO (Ptr CDir) - -foreign import ccall unsafe "HsBase.h __hscore_mkdir" - mkdir :: CString -> CInt -> IO CInt + c_open :: CFilePath -> CInt -> CMode -> IO CInt foreign import ccall unsafe "HsBase.h read" - c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize + c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall unsafe "HsBase.h rewinddir" - c_rewinddir :: Ptr CDir -> IO () +foreign import ccall safe "HsBase.h read" + c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize foreign import ccall unsafe "HsBase.h __hscore_stat" - c_stat :: CString -> Ptr CStat -> IO CInt + c_stat :: CFilePath -> Ptr CStat -> IO CInt foreign import ccall unsafe "HsBase.h umask" c_umask :: CMode -> IO CMode foreign import ccall unsafe "HsBase.h write" - c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize + c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize +foreign import ccall safe "HsBase.h write" + c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize + foreign import ccall unsafe "HsBase.h __hscore_ftruncate" c_ftruncate :: CInt -> COff -> IO CInt @@ -401,13 +423,13 @@ c_getpid :: IO CPid #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) -foreign import ccall unsafe "HsBase.h fcntl" +foreign import ccall unsafe "HsBase.h fcntl_read" c_fcntl_read :: CInt -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h fcntl" +foreign import ccall unsafe "HsBase.h fcntl_write" c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt -foreign import ccall unsafe "HsBase.h fcntl" +foreign import ccall unsafe "HsBase.h fcntl_lock" c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt foreign import ccall unsafe "HsBase.h fork" @@ -437,26 +459,13 @@ foreign import ccall unsafe "HsBase.h tcsetattr" c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt -foreign import ccall unsafe "HsBase.h utime" +foreign import ccall unsafe "HsBase.h __hscore_utime" c_utime :: CString -> Ptr CUtimbuf -> IO CInt foreign import ccall unsafe "HsBase.h waitpid" c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid #endif --- traversing directories -foreign import ccall unsafe "dirUtils.h __hscore_readdir" - readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt - -foreign import ccall unsafe "HsBase.h __hscore_free_dirent" - freeDirEnt :: Ptr CDirent -> IO () - -foreign import ccall unsafe "HsBase.h __hscore_end_of_dir" - end_of_dir :: CInt - -foreign import ccall unsafe "HsBase.h __hscore_d_name" - d_name :: Ptr CDirent -> IO CString - -- POSIX flags only: foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt @@ -528,3 +537,10 @@ #else s_issock _ = False #endif + +--foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int +dEFAULT_BUFFER_SIZE :: Int +dEFAULT_BUFFER_SIZE = 512 +--foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt +--foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt +--foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt diff --git a/lib/base/src/System/Posix/Types.hs b/lib/base/src/System/Posix/Types.hs --- a/lib/base/src/System/Posix/Types.hs +++ b/lib/base/src/System/Posix/Types.hs @@ -31,7 +31,9 @@ #define HTYPE_NLINK_T #define HTYPE_UID_T #define HTYPE_GID_T +#elif __LHC__ #else +#include "HsBaseConfig.h" #endif module System.Posix.Types ( @@ -59,9 +61,7 @@ #if defined(HTYPE_SPEED_T) CSpeed, #endif -#if defined(HTYPE_TCFLAG_T) CTcflag, -#endif #if defined(HTYPE_RLIM_T) CRLim, #endif @@ -97,7 +97,7 @@ import Foreign import Foreign.C ---import Data.Typeable +import Data.Typeable import Data.Bits #ifdef __GLASGOW_HASKELL__ @@ -105,7 +105,7 @@ import GHC.Enum import GHC.Num import GHC.Real -import GHC.Prim +-- import GHC.Prim import GHC.Read import GHC.Show #else @@ -120,7 +120,13 @@ newtype CPid = CPid Int32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum) newtype COff = COff Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum) newtype CSsize = CSsize Int64 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum) +newtype CTcflag = CTcflag Word32 deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum,Bits) +{-# RULES +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CSsize (fromInteger (smallInteger x)) +"smallInteger/fromInteger" forall x. fromInteger (smallInteger x) = CMode (fromInteger (smallInteger x)) + #-} + #if defined(HTYPE_DEV_T) ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T) #endif @@ -170,7 +176,6 @@ -- Make an Fd type rather than using CInt everywhere {-INTEGRAL_TYPE(Fd,tyConFd,"Fd",CInt)-} newtype Fd = Fd CInt deriving (Show,Eq,Ord,Num,Storable,Integral,Real,Enum) - -- nicer names, and backwards compatibility with POSIX library: #if defined(HTYPE_NLINK_T) diff --git a/lib/base/src/System/Timeout.hs b/lib/base/src/System/Timeout.hs new file mode 100644 --- /dev/null +++ b/lib/base/src/System/Timeout.hs @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------- +-- | +-- Module : System.Timeout +-- Copyright : (c) The University of Glasgow 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Attach a timeout event to arbitrary 'IO' computations. +-- +------------------------------------------------------------------------------- + +#ifdef __GLASGOW_HASKELL__ +#include "Typeable.h" +#endif + +module System.Timeout ( timeout ) where + +#ifdef __GLASGOW_HASKELL__ +import Prelude (Show(show), IO, Ord((<)), Eq((==)), Int, + otherwise, fmap) +import Data.Maybe (Maybe(..)) +import Control.Monad (Monad(..)) +import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread) +import Control.Exception (Exception, handleJust, throwTo, bracket) +import Data.Typeable +import Data.Unique (Unique, newUnique) +import GHC.Num + +-- An internal type that is thrown as a dynamic exception to +-- interrupt the running IO computation when the timeout has +-- expired. + +data Timeout = Timeout Unique deriving Eq +INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout") + +instance Show Timeout where + show _ = "<>" + +instance Exception Timeout +#endif /* !__GLASGOW_HASKELL__ */ + +-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result +-- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result +-- is available before the timeout expires, @Just a@ is returned. A negative +-- timeout interval means \"wait indefinitely\". When specifying long timeouts, +-- be careful not to exceed @maxBound :: Int@. +-- +-- The design of this combinator was guided by the objective that @timeout n f@ +-- should behave exactly the same as @f@ as long as @f@ doesn't time out. This +-- means that @f@ has the same 'myThreadId' it would have without the timeout +-- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate +-- further up. It also possible for @f@ to receive exceptions thrown to it by +-- another thread. +-- +-- A tricky implementation detail is the question of how to abort an @IO@ +-- computation. This combinator relies on asynchronous exceptions internally. +-- The technique works very well for computations executing inside of the +-- Haskell runtime system, but it doesn't work at all for non-Haskell code. +-- Foreign function calls, for example, cannot be timed out with this +-- combinator simply because an arbitrary C function cannot receive +-- asynchronous exceptions. When @timeout@ is used to wrap an FFI call that +-- blocks, no timeout event can be delivered until the FFI call returns, which +-- pretty much negates the purpose of the combinator. In practice, however, +-- this limitation is less severe than it may sound. Standard I\/O functions +-- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', Network.Socket.accept, or +-- 'System.IO.hWaitForInput' appear to be blocking, but they really don't +-- because the runtime system uses scheduling mechanisms like @select(2)@ to +-- perform asynchronous I\/O, so it is possible to interrupt standard socket +-- I\/O or file I\/O using this combinator. + +timeout :: Int -> IO a -> IO (Maybe a) +#ifdef __GLASGOW_HASKELL__ +timeout n f + | n < 0 = fmap Just f + | n == 0 = return Nothing + | otherwise = do + pid <- myThreadId + ex <- fmap Timeout newUnique + handleJust (\e -> if e == ex then Just () else Nothing) + (\_ -> return Nothing) + (bracket (forkIO (threadDelay n >> throwTo pid ex)) + (killThread) + (\_ -> fmap Just f)) +#else +timeout n f = fmap Just f +#endif /* !__GLASGOW_HASKELL__ */ diff --git a/lib/ghc-prim/GHC/Debug.hs b/lib/ghc-prim/GHC/Debug.hs new file mode 100644 --- /dev/null +++ b/lib/ghc-prim/GHC/Debug.hs @@ -0,0 +1,46 @@ + +module GHC.Debug (debugLn, debugErrLn) where + +import GHC.Prim +import GHC.Types +import GHC.Unit () + +debugLn :: [Char] -> IO () +debugLn xs = IO (\s0 -> + case mkMBA s0 xs of + (# s1, mba #) -> + case c_debugLn mba of + IO f -> f s1) + +debugErrLn :: [Char] -> IO () +debugErrLn xs = IO (\s0 -> + case mkMBA s0 xs of + (# s1, mba #) -> + case c_debugErrLn mba of + IO f -> f s1) + +foreign import ccall unsafe "debugLn" + c_debugLn :: MutableByteArray# RealWorld -> IO () + +foreign import ccall unsafe "debugErrLn" + c_debugErrLn :: MutableByteArray# RealWorld -> IO () + +mkMBA :: State# RealWorld -> [Char] -> + (# State# RealWorld, MutableByteArray# RealWorld #) +mkMBA s0 xs = -- Start with 1 so that we have space to put in a \0 at + -- the end + case len 1# xs of + l -> + case newByteArray# l s0 of + (# s1, mba #) -> + case write mba 0# xs s1 of + s2 -> (# s2, mba #) + where len l [] = l + len l (_ : xs') = len (l +# 1#) xs' + + write mba offset [] s = writeCharArray# mba offset '\0'# s + write mba offset (C# x : xs') s + = case writeCharArray# mba offset x s of + s' -> + write mba (offset +# 1#) xs' s' + diff --git a/lib/ghc-prim/GHC/Generics.hs b/lib/ghc-prim/GHC/Generics.hs --- a/lib/ghc-prim/GHC/Generics.hs +++ b/lib/ghc-prim/GHC/Generics.hs @@ -1,5 +1,4 @@ - -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -XTypeOperators #-} module GHC.Generics where diff --git a/lib/ghc-prim/GHC/IntWord32.hs b/lib/ghc-prim/GHC/IntWord32.hs --- a/lib/ghc-prim/GHC/IntWord32.hs +++ b/lib/ghc-prim/GHC/IntWord32.hs @@ -15,59 +15,7 @@ -- ----------------------------------------------------------------------------- --- include "MachDeps.h" - -#define WORD_SIZE_IN_BITS 64 - -- #hide module GHC.IntWord32 ( -#if WORD_SIZE_IN_BITS < 32 - Int32#, Word32#, module GHC.IntWord32 -#endif ) where - -#if WORD_SIZE_IN_BITS < 32 -import GHC.Bool -import GHC.Prim - -foreign import unsafe "stg_eqWord32" eqWord32# :: Word32# -> Word32# -> Bool -foreign import unsafe "stg_neWord32" neWord32# :: Word32# -> Word32# -> Bool -foreign import unsafe "stg_ltWord32" ltWord32# :: Word32# -> Word32# -> Bool -foreign import unsafe "stg_leWord32" leWord32# :: Word32# -> Word32# -> Bool -foreign import unsafe "stg_gtWord32" gtWord32# :: Word32# -> Word32# -> Bool -foreign import unsafe "stg_geWord32" geWord32# :: Word32# -> Word32# -> Bool - -foreign import unsafe "stg_eqInt32" eqInt32# :: Int32# -> Int32# -> Bool -foreign import unsafe "stg_neInt32" neInt32# :: Int32# -> Int32# -> Bool -foreign import unsafe "stg_ltInt32" ltInt32# :: Int32# -> Int32# -> Bool -foreign import unsafe "stg_leInt32" leInt32# :: Int32# -> Int32# -> Bool -foreign import unsafe "stg_gtInt32" gtInt32# :: Int32# -> Int32# -> Bool -foreign import unsafe "stg_geInt32" geInt32# :: Int32# -> Int32# -> Bool - -foreign import unsafe "stg_int32ToWord32" int32ToWord32# :: Int32# -> Word32# -foreign import unsafe "stg_word32ToInt32" word32ToInt32# :: Word32# -> Int32# -foreign import unsafe "stg_intToInt32" intToInt32# :: Int# -> Int32# -foreign import unsafe "stg_wordToWord32" wordToWord32# :: Word# -> Word32# -foreign import unsafe "stg_word32ToWord" word32ToWord# :: Word32# -> Word# - -foreign import unsafe "stg_plusInt32" plusInt32# :: Int32# -> Int32# -> Int32# -foreign import unsafe "stg_minusInt32" minusInt32# :: Int32# -> Int32# -> Int32# -foreign import unsafe "stg_timesInt32" timesInt32# :: Int32# -> Int32# -> Int32# -foreign import unsafe "stg_negateInt32" negateInt32# :: Int32# -> Int32# -foreign import unsafe "stg_quotInt32" quotInt32# :: Int32# -> Int32# -> Int32# -foreign import unsafe "stg_remInt32" remInt32# :: Int32# -> Int32# -> Int32# -foreign import unsafe "stg_quotWord32" quotWord32# :: Word32# -> Word32# -> Word32# -foreign import unsafe "stg_remWord32" remWord32# :: Word32# -> Word32# -> Word32# - -foreign import unsafe "stg_and32" and32# :: Word32# -> Word32# -> Word32# -foreign import unsafe "stg_or32" or32# :: Word32# -> Word32# -> Word32# -foreign import unsafe "stg_xor32" xor32# :: Word32# -> Word32# -> Word32# -foreign import unsafe "stg_not32" not32# :: Word32# -> Word32# - -foreign import unsafe "stg_iShiftL32" iShiftL32# :: Int32# -> Int# -> Int32# -foreign import unsafe "stg_iShiftRA32" iShiftRA32# :: Int32# -> Int# -> Int32# -foreign import unsafe "stg_shiftL32" shiftL32# :: Word32# -> Int# -> Word32# -foreign import unsafe "stg_shiftRL32" shiftRL32# :: Word32# -> Int# -> Word32# - -#endif diff --git a/lib/ghc-prim/GHC/IntWord64.hs b/lib/ghc-prim/GHC/IntWord64.hs --- a/lib/ghc-prim/GHC/IntWord64.hs +++ b/lib/ghc-prim/GHC/IntWord64.hs @@ -15,8 +15,6 @@ -- ----------------------------------------------------------------------------- --- include "MachDeps.h" - -- #hide module GHC.IntWord64 ( #if WORD_SIZE_IN_BITS < 64 @@ -62,8 +60,6 @@ foreign import ccall unsafe "hs_uncheckedIShiftRA64" uncheckedIShiftRA64# :: Int64# -> Int# -> Int64# foreign import ccall unsafe "hs_uncheckedIShiftRL64" uncheckedIShiftRL64# :: Int64# -> Int# -> Int64# -foreign import ccall unsafe "hs_integerToWord64" integerToWord64# :: Int# -> ByteArray# -> Word64# -foreign import ccall unsafe "hs_integerToInt64" integerToInt64# :: Int# -> ByteArray# -> Int64# foreign import ccall unsafe "hs_int64ToWord64" int64ToWord64# :: Int64# -> Word64# foreign import ccall unsafe "hs_word64ToInt64" word64ToInt64# :: Word64# -> Int64# foreign import ccall unsafe "hs_intToInt64" intToInt64# :: Int# -> Int64# diff --git a/lib/ghc-prim/GHC/Magic.hs b/lib/ghc-prim/GHC/Magic.hs new file mode 100644 --- /dev/null +++ b/lib/ghc-prim/GHC/Magic.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Magic +-- Copyright : (c) The University of Glasgow 2009 +-- License : see libraries/ghc-prim/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- GHC magic. +-- Use GHC.Exts from the base package instead of importing this +-- module directly. +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Magic (inline) where + +-- | The call '(inline f)' reduces to 'f', but 'inline' has a BuiltInRule +-- that tries to inline 'f' (if it has an unfolding) unconditionally +-- The 'NOINLINE' pragma arranges that inline only gets inlined (and +-- hence eliminated) late in compilation, after the rule has had +-- a good chance to fire. +inline :: a -> a +{-# NOINLINE[0] inline #-} +inline x = x + diff --git a/lib/ghc-prim/GHC/Prim.hs b/lib/ghc-prim/GHC/Prim.hs deleted file mode 100644 --- a/lib/ghc-prim/GHC/Prim.hs +++ /dev/null @@ -1,1874 +0,0 @@ -{- -This is a generated file (generated by genprimopcode). -It is not code to actually be used. Its only purpose is to be -consumed by haddock. --} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Prim --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC extensions) --- --- GHC's primitive types and operations. --- ------------------------------------------------------------------------------ -module GHC.Prim ( - --- * The word size story. --- |Haskell98 specifies that signed integers (type @Int@) --- must contain at least 30 bits. GHC always implements @Int@ using the primitive type @Int\#@, whose size equals --- the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@. --- This is normally set based on the @config.h@ parameter --- @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64 --- bits on 64-bit machines. However, it can also be explicitly --- set to a smaller number, e.g., 31 bits, to allow the --- possibility of using tag bits. Currently GHC itself has only --- 32-bit and 64-bit variants, but 30 or 31-bit code can be --- exported as an external core file for use in other back ends. --- --- GHC also implements a primitive unsigned integer type @Word\#@ which always has the same number of bits as @Int\#@. --- --- In addition, GHC supports families of explicit-sized integers --- and words at 8, 16, 32, and 64 bits, with the usual --- arithmetic operations, comparisons, and a range of --- conversions. The 8-bit and 16-bit sizes are always --- represented as @Int\#@ and @Word\#@, and the --- operations implemented in terms of the the primops on these --- types, with suitable range restrictions on the results (using --- the @narrow$n$Int\#@ and @narrow$n$Word\#@ families --- of primops. The 32-bit sizes are represented using @Int\#@ and @Word\#@ when @WORD\_SIZE\_IN\_BITS@ --- $\geq$ 32; otherwise, these are represented using distinct --- primitive types @Int32\#@ and @Word32\#@. These (when --- needed) have a complete set of corresponding operations; --- however, nearly all of these are implemented as external C --- functions rather than as primops. Exactly the same story --- applies to the 64-bit sizes. All of these details are hidden --- under the @PrelInt@ and @PrelWord@ modules, which use --- @\#if@-defs to invoke the appropriate types and --- operators. --- --- Word size also matters for the families of primops for --- indexing\/reading\/writing fixed-size quantities at offsets --- from an array base, address, or foreign pointer. Here, a --- slightly different approach is taken. The names of these --- primops are fixed, but their /types/ vary according to --- the value of @WORD\_SIZE\_IN\_BITS@. For example, if word --- size is at least 32 bits then an operator like --- @indexInt32Array\#@ has type @ByteArray\# -> Int\# -> Int\#@; otherwise it has type @ByteArray\# -> Int\# -> Int32\#@. This approach confines the necessary @\#if@-defs to this file; no conditional compilation is needed --- in the files that expose these primops. --- --- Finally, there are strongly deprecated primops for coercing --- between @Addr\#@, the primitive type of machine --- addresses, and @Int\#@. These are pretty bogus anyway, --- but will work on existing 32-bit and 64-bit GHC targets; they --- are completely bogus when tag bits are used in @Int\#@, --- so are not available in this case. - - - --- * Char# --- |Operations on 31-bit characters. - - - Char#, - gtChar#, - geChar#, - eqChar#, - neChar#, - ltChar#, - leChar#, - ord#, - --- * Int# --- |Operations on native-size integers (30+ bits). - - - Int#, - (+#), - (-#), - (*#), - mulIntMayOflo#, - quotInt#, - remInt#, - gcdInt#, - negateInt#, - addIntC#, - subIntC#, - (>#), - (>=#), - (==#), - (/=#), - (<#), - (<=#), - chr#, - int2Word#, - int2Float#, - int2Double#, - int2Integer#, - uncheckedIShiftL#, - uncheckedIShiftRA#, - uncheckedIShiftRL#, - --- * Word# --- |Operations on native-sized unsigned words (30+ bits). - - - Word#, - plusWord#, - minusWord#, - timesWord#, - quotWord#, - remWord#, - and#, - or#, - xor#, - not#, - uncheckedShiftL#, - uncheckedShiftRL#, - word2Int#, - word2Integer#, - gtWord#, - geWord#, - eqWord#, - neWord#, - ltWord#, - leWord#, - --- * Narrowings --- |Explicit narrowing of native-sized ints or words. - - - narrow8Int#, - narrow16Int#, - narrow32Int#, - narrow8Word#, - narrow16Word#, - narrow32Word#, - --- * Integer# --- |Operations on arbitrary-precision integers. These operations are --- implemented via the GMP package. An integer is represented as a pair --- consisting of an @Int\#@ representing the number of \'limbs\' in use and --- the sign, and a @ByteArray\#@ containing the \'limbs\' themselves. Such pairs --- are returned as unboxed pairs, but must be passed as separate --- components. --- --- For .NET these operations are implemented by foreign imports, so the --- primops are omitted. - - - plusInteger#, - minusInteger#, - timesInteger#, - gcdInteger#, - gcdIntegerInt#, - divExactInteger#, - quotInteger#, - remInteger#, - cmpInteger#, - cmpIntegerInt#, - quotRemInteger#, - divModInteger#, - integer2Int#, - integer2Word#, - andInteger#, - orInteger#, - xorInteger#, - complementInteger#, - --- * Double# --- |Operations on double-precision (64 bit) floating-point numbers. - - - Double#, - (>##), - (>=##), - (==##), - (/=##), - (<##), - (<=##), - (+##), - (-##), - (*##), - (/##), - negateDouble#, - double2Int#, - double2Float#, - expDouble#, - logDouble#, - sqrtDouble#, - sinDouble#, - cosDouble#, - tanDouble#, - asinDouble#, - acosDouble#, - atanDouble#, - sinhDouble#, - coshDouble#, - tanhDouble#, - (**##), - decodeDouble#, - decodeDouble_2Int#, - --- * Float# --- |Operations on single-precision (32-bit) floating-point numbers. - - - Float#, - gtFloat#, - geFloat#, - eqFloat#, - neFloat#, - ltFloat#, - leFloat#, - plusFloat#, - minusFloat#, - timesFloat#, - divideFloat#, - negateFloat#, - float2Int#, - expFloat#, - logFloat#, - sqrtFloat#, - sinFloat#, - cosFloat#, - tanFloat#, - asinFloat#, - acosFloat#, - atanFloat#, - sinhFloat#, - coshFloat#, - tanhFloat#, - powerFloat#, - float2Double#, - decodeFloat#, - decodeFloat_Int#, - --- * Arrays --- |Operations on @Array\#@. - - - Array#, - MutableArray#, - newArray#, - sameMutableArray#, - readArray#, - writeArray#, - indexArray#, - unsafeFreezeArray#, - unsafeThawArray#, - --- * Byte Arrays --- |Operations on @ByteArray\#@. A @ByteArray\#@ is a just a region of --- raw memory in the garbage-collected heap, which is not scanned --- for pointers. It carries its own size (in bytes). There are --- three sets of operations for accessing byte array contents: --- index for reading from immutable byte arrays, and read\/write --- for mutable byte arrays. Each set contains operations for --- a range of useful primitive data types. Each operation takes --- an offset measured in terms of the size fo the primitive type --- being read or written. - - - ByteArray#, - MutableByteArray#, - newByteArray#, - newPinnedByteArray#, - newAlignedPinnedByteArray#, - byteArrayContents#, - sameMutableByteArray#, - unsafeFreezeByteArray#, - sizeofByteArray#, - sizeofMutableByteArray#, - indexCharArray#, - indexWideCharArray#, - indexIntArray#, - indexWordArray#, - indexAddrArray#, - indexFloatArray#, - indexDoubleArray#, - indexStablePtrArray#, - indexInt8Array#, - indexInt16Array#, - indexInt32Array#, - indexInt64Array#, - indexWord8Array#, - indexWord16Array#, - indexWord32Array#, - indexWord64Array#, - readCharArray#, - readWideCharArray#, - readIntArray#, - readWordArray#, - readAddrArray#, - readFloatArray#, - readDoubleArray#, - readStablePtrArray#, - readInt8Array#, - readInt16Array#, - readInt32Array#, - readInt64Array#, - readWord8Array#, - readWord16Array#, - readWord32Array#, - readWord64Array#, - writeCharArray#, - writeWideCharArray#, - writeIntArray#, - writeWordArray#, - writeAddrArray#, - writeFloatArray#, - writeDoubleArray#, - writeStablePtrArray#, - writeInt8Array#, - writeInt16Array#, - writeInt32Array#, - writeInt64Array#, - writeWord8Array#, - writeWord16Array#, - writeWord32Array#, - writeWord64Array#, - --- * Addr# --- | - - - Addr#, - nullAddr#, - plusAddr#, - minusAddr#, - remAddr#, - addr2Int#, - int2Addr#, - gtAddr#, - geAddr#, - eqAddr#, - neAddr#, - ltAddr#, - leAddr#, - indexCharOffAddr#, - indexWideCharOffAddr#, - indexIntOffAddr#, - indexWordOffAddr#, - indexAddrOffAddr#, - indexFloatOffAddr#, - indexDoubleOffAddr#, - indexStablePtrOffAddr#, - indexInt8OffAddr#, - indexInt16OffAddr#, - indexInt32OffAddr#, - indexInt64OffAddr#, - indexWord8OffAddr#, - indexWord16OffAddr#, - indexWord32OffAddr#, - indexWord64OffAddr#, - readCharOffAddr#, - readWideCharOffAddr#, - readIntOffAddr#, - readWordOffAddr#, - readAddrOffAddr#, - readFloatOffAddr#, - readDoubleOffAddr#, - readStablePtrOffAddr#, - readInt8OffAddr#, - readInt16OffAddr#, - readInt32OffAddr#, - readInt64OffAddr#, - readWord8OffAddr#, - readWord16OffAddr#, - readWord32OffAddr#, - readWord64OffAddr#, - writeCharOffAddr#, - writeWideCharOffAddr#, - writeIntOffAddr#, - writeWordOffAddr#, - writeAddrOffAddr#, - writeFloatOffAddr#, - writeDoubleOffAddr#, - writeStablePtrOffAddr#, - writeInt8OffAddr#, - writeInt16OffAddr#, - writeInt32OffAddr#, - writeInt64OffAddr#, - writeWord8OffAddr#, - writeWord16OffAddr#, - writeWord32OffAddr#, - writeWord64OffAddr#, - --- * Mutable variables --- |Operations on MutVar\#s. - - - MutVar#, - newMutVar#, - readMutVar#, - writeMutVar#, - sameMutVar#, - atomicModifyMutVar#, - --- * Exceptions --- | - - - catch#, - raise#, - raiseIO#, - blockAsyncExceptions#, - unblockAsyncExceptions#, - asyncExceptionsBlocked#, - --- * STM-accessible Mutable Variables --- | - - - TVar#, - atomically#, - retry#, - catchRetry#, - catchSTM#, - check#, - newTVar#, - readTVar#, - writeTVar#, - sameTVar#, - --- * Synchronized Mutable Variables --- |Operations on @MVar\#@s. - - - MVar#, - newMVar#, - takeMVar#, - tryTakeMVar#, - putMVar#, - tryPutMVar#, - sameMVar#, - isEmptyMVar#, - --- * Delay\/wait operations --- | - - - delay#, - waitRead#, - waitWrite#, - --- * Concurrency primitives --- | - - - State#, - RealWorld, - ThreadId#, - fork#, - forkOn#, - killThread#, - yield#, - myThreadId#, - labelThread#, - isCurrentThreadBound#, - noDuplicate#, - threadStatus#, - --- * Weak pointers --- | - - - Weak#, - mkWeak#, - mkWeakForeignEnv#, - deRefWeak#, - finalizeWeak#, - touch#, - --- * Stable pointers and names --- | - - - StablePtr#, - StableName#, - makeStablePtr#, - deRefStablePtr#, - eqStablePtr#, - makeStableName#, - eqStableName#, - stableNameToInt#, - --- * Unsafe pointer equality --- | - - - reallyUnsafePtrEquality#, - --- * Parallelism --- | - - - par#, - parGlobal#, - parLocal#, - parAt#, - parAtAbs#, - parAtRel#, - parAtForNow#, - --- * Tag to enum stuff --- |Convert back and forth between values of enumerated types --- and small integers. - - - dataToTag#, - tagToEnum#, - --- * Bytecode operations --- |Support for the bytecode interpreter and linker. - - - BCO#, - addrToHValue#, - mkApUpd0#, - newBCO#, - unpackClosure#, - getApStackVal#, - --- * Etc --- |Miscellaneous built-ins - - - seq, - inline, - lazy, - Any, - unsafeCoerce#, -) where - -import GHC.Bool - -{- -has_side_effects = False -out_of_line = False -commutable = False -needs_wrapper = False -can_fail = False -strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) } --} - -data Char# - -gtChar# :: Char# -> Char# -> Bool -gtChar# = let x = x in x - -geChar# :: Char# -> Char# -> Bool -geChar# = let x = x in x - -eqChar# :: Char# -> Char# -> Bool -eqChar# = let x = x in x - -neChar# :: Char# -> Char# -> Bool -neChar# = let x = x in x - -ltChar# :: Char# -> Char# -> Bool -ltChar# = let x = x in x - -leChar# :: Char# -> Char# -> Bool -leChar# = let x = x in x - -ord# :: Char# -> Int# -ord# = let x = x in x - -data Int# - -(+#) :: Int# -> Int# -> Int# -(+#) = let x = x in x - -(-#) :: Int# -> Int# -> Int# -(-#) = let x = x in x - --- |Low word of signed integer multiply. - -(*#) :: Int# -> Int# -> Int# -(*#) = let x = x in x - --- |Return non-zero if there is any possibility that the upper word of a --- signed integer multiply might contain useful information. Return --- zero only if you are completely sure that no overflow can occur. --- On a 32-bit platform, the recommmended implementation is to do a --- 32 x 32 -> 64 signed multiply, and subtract result[63:32] from --- (result[31] >>signed 31). If this is zero, meaning that the --- upper word is merely a sign extension of the lower one, no --- overflow can occur. --- --- On a 64-bit platform it is not always possible to --- acquire the top 64 bits of the result. Therefore, a recommended --- implementation is to take the absolute value of both operands, and --- return 0 iff bits[63:31] of them are zero, since that means that their --- magnitudes fit within 31 bits, so the magnitude of the product must fit --- into 62 bits. --- --- If in doubt, return non-zero, but do make an effort to create the --- correct answer for small args, since otherwise the performance of --- @(*) :: Integer -> Integer -> Integer@ will be poor. --- - -mulIntMayOflo# :: Int# -> Int# -> Int# -mulIntMayOflo# = let x = x in x - --- |Rounds towards zero. - -quotInt# :: Int# -> Int# -> Int# -quotInt# = let x = x in x - --- |Satisfies @(quotInt\# x y) *\# y +\# (remInt\# x y) == x@. - -remInt# :: Int# -> Int# -> Int# -remInt# = let x = x in x - -gcdInt# :: Int# -> Int# -> Int# -gcdInt# = let x = x in x - -negateInt# :: Int# -> Int# -negateInt# = let x = x in x - --- |Add with carry. First member of result is (wrapped) sum; --- second member is 0 iff no overflow occured. - -addIntC# :: Int# -> Int# -> (# Int#,Int# #) -addIntC# = let x = x in x - --- |Subtract with carry. First member of result is (wrapped) difference; --- second member is 0 iff no overflow occured. - -subIntC# :: Int# -> Int# -> (# Int#,Int# #) -subIntC# = let x = x in x - -(>#) :: Int# -> Int# -> Bool -(>#) = let x = x in x - -(>=#) :: Int# -> Int# -> Bool -(>=#) = let x = x in x - -(==#) :: Int# -> Int# -> Bool -(==#) = let x = x in x - -(/=#) :: Int# -> Int# -> Bool -(/=#) = let x = x in x - -(<#) :: Int# -> Int# -> Bool -(<#) = let x = x in x - -(<=#) :: Int# -> Int# -> Bool -(<=#) = let x = x in x - -chr# :: Int# -> Char# -chr# = let x = x in x - -int2Word# :: Int# -> Word# -int2Word# = let x = x in x - -int2Float# :: Int# -> Float# -int2Float# = let x = x in x - -int2Double# :: Int# -> Double# -int2Double# = let x = x in x - -int2Integer# :: Int# -> (# Int#,ByteArray# #) -int2Integer# = let x = x in x - --- |Shift left. Result undefined if shift amount is not --- in the range 0 to word size - 1 inclusive. - -uncheckedIShiftL# :: Int# -> Int# -> Int# -uncheckedIShiftL# = let x = x in x - --- |Shift right arithmetic. Result undefined if shift amount is not --- in the range 0 to word size - 1 inclusive. - -uncheckedIShiftRA# :: Int# -> Int# -> Int# -uncheckedIShiftRA# = let x = x in x - --- |Shift right logical. Result undefined if shift amount is not --- in the range 0 to word size - 1 inclusive. - -uncheckedIShiftRL# :: Int# -> Int# -> Int# -uncheckedIShiftRL# = let x = x in x - -data Word# - -plusWord# :: Word# -> Word# -> Word# -plusWord# = let x = x in x - -minusWord# :: Word# -> Word# -> Word# -minusWord# = let x = x in x - -timesWord# :: Word# -> Word# -> Word# -timesWord# = let x = x in x - -quotWord# :: Word# -> Word# -> Word# -quotWord# = let x = x in x - -remWord# :: Word# -> Word# -> Word# -remWord# = let x = x in x - -and# :: Word# -> Word# -> Word# -and# = let x = x in x - -or# :: Word# -> Word# -> Word# -or# = let x = x in x - -xor# :: Word# -> Word# -> Word# -xor# = let x = x in x - -not# :: Word# -> Word# -not# = let x = x in x - --- |Shift left logical. Result undefined if shift amount is not --- in the range 0 to word size - 1 inclusive. - -uncheckedShiftL# :: Word# -> Int# -> Word# -uncheckedShiftL# = let x = x in x - --- |Shift right logical. Result undefined if shift amount is not --- in the range 0 to word size - 1 inclusive. - -uncheckedShiftRL# :: Word# -> Int# -> Word# -uncheckedShiftRL# = let x = x in x - -word2Int# :: Word# -> Int# -word2Int# = let x = x in x - -word2Integer# :: Word# -> (# Int#,ByteArray# #) -word2Integer# = let x = x in x - -gtWord# :: Word# -> Word# -> Bool -gtWord# = let x = x in x - -geWord# :: Word# -> Word# -> Bool -geWord# = let x = x in x - -eqWord# :: Word# -> Word# -> Bool -eqWord# = let x = x in x - -neWord# :: Word# -> Word# -> Bool -neWord# = let x = x in x - -ltWord# :: Word# -> Word# -> Bool -ltWord# = let x = x in x - -leWord# :: Word# -> Word# -> Bool -leWord# = let x = x in x - -narrow8Int# :: Int# -> Int# -narrow8Int# = let x = x in x - -narrow16Int# :: Int# -> Int# -narrow16Int# = let x = x in x - -narrow32Int# :: Int# -> Int# -narrow32Int# = let x = x in x - -narrow8Word# :: Word# -> Word# -narrow8Word# = let x = x in x - -narrow16Word# :: Word# -> Word# -narrow16Word# = let x = x in x - -narrow32Word# :: Word# -> Word# -narrow32Word# = let x = x in x - -plusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -plusInteger# = let x = x in x - -minusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -minusInteger# = let x = x in x - -timesInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -timesInteger# = let x = x in x - --- |Greatest common divisor. - -gcdInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -gcdInteger# = let x = x in x - --- |Greatest common divisor, where second argument is an ordinary @Int\#@. - -gcdIntegerInt# :: Int# -> ByteArray# -> Int# -> Int# -gcdIntegerInt# = let x = x in x - --- |Divisor is guaranteed to be a factor of dividend. - -divExactInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -divExactInteger# = let x = x in x - --- |Rounds towards zero. - -quotInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -quotInteger# = let x = x in x - --- |Satisfies @plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x@. - -remInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -remInteger# = let x = x in x - --- |Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument. - -cmpInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int# -cmpInteger# = let x = x in x - --- |Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which --- is an ordinary Int\#. - -cmpIntegerInt# :: Int# -> ByteArray# -> Int# -> Int# -cmpIntegerInt# = let x = x in x - --- |Compute quot and rem simulaneously. - -quotRemInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #) -quotRemInteger# = let x = x in x - --- |Compute div and mod simultaneously, where div rounds towards negative infinity --- and@(q,r) = divModInteger\#(x,y)@ implies @plusInteger\# (timesInteger\# q y) r = x@. - -divModInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #) -divModInteger# = let x = x in x - -integer2Int# :: Int# -> ByteArray# -> Int# -integer2Int# = let x = x in x - -integer2Word# :: Int# -> ByteArray# -> Word# -integer2Word# = let x = x in x - -andInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -andInteger# = let x = x in x - -orInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -orInteger# = let x = x in x - -xorInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -xorInteger# = let x = x in x - -complementInteger# :: Int# -> ByteArray# -> (# Int#,ByteArray# #) -complementInteger# = let x = x in x - -data Double# - -(>##) :: Double# -> Double# -> Bool -(>##) = let x = x in x - -(>=##) :: Double# -> Double# -> Bool -(>=##) = let x = x in x - -(==##) :: Double# -> Double# -> Bool -(==##) = let x = x in x - -(/=##) :: Double# -> Double# -> Bool -(/=##) = let x = x in x - -(<##) :: Double# -> Double# -> Bool -(<##) = let x = x in x - -(<=##) :: Double# -> Double# -> Bool -(<=##) = let x = x in x - -(+##) :: Double# -> Double# -> Double# -(+##) = let x = x in x - -(-##) :: Double# -> Double# -> Double# -(-##) = let x = x in x - -(*##) :: Double# -> Double# -> Double# -(*##) = let x = x in x - -(/##) :: Double# -> Double# -> Double# -(/##) = let x = x in x - -negateDouble# :: Double# -> Double# -negateDouble# = let x = x in x - --- |Truncates a @Double#@ value to the nearest @Int#@. --- Results are undefined if the truncation if truncation yields --- a value outside the range of @Int#@. - -double2Int# :: Double# -> Int# -double2Int# = let x = x in x - -double2Float# :: Double# -> Float# -double2Float# = let x = x in x - -expDouble# :: Double# -> Double# -expDouble# = let x = x in x - -logDouble# :: Double# -> Double# -logDouble# = let x = x in x - -sqrtDouble# :: Double# -> Double# -sqrtDouble# = let x = x in x - -sinDouble# :: Double# -> Double# -sinDouble# = let x = x in x - -cosDouble# :: Double# -> Double# -cosDouble# = let x = x in x - -tanDouble# :: Double# -> Double# -tanDouble# = let x = x in x - -asinDouble# :: Double# -> Double# -asinDouble# = let x = x in x - -acosDouble# :: Double# -> Double# -acosDouble# = let x = x in x - -atanDouble# :: Double# -> Double# -atanDouble# = let x = x in x - -sinhDouble# :: Double# -> Double# -sinhDouble# = let x = x in x - -coshDouble# :: Double# -> Double# -coshDouble# = let x = x in x - -tanhDouble# :: Double# -> Double# -tanhDouble# = let x = x in x - --- |Exponentiation. - -(**##) :: Double# -> Double# -> Double# -(**##) = let x = x in x - --- |Convert to arbitrary-precision integer. --- First @Int\#@ in result is the exponent; second @Int\#@ and @ByteArray\#@ --- represent an @Integer\#@ holding the mantissa. - -decodeDouble# :: Double# -> (# Int#,Int#,ByteArray# #) -decodeDouble# = let x = x in x - --- |Convert to arbitrary-precision integer. --- First component of the result is -1 or 1, indicating the sign of the --- mantissa. The next two are the high and low 32 bits of the mantissa --- respectively, and the last is the exponent. - -decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #) -decodeDouble_2Int# = let x = x in x - -data Float# - -gtFloat# :: Float# -> Float# -> Bool -gtFloat# = let x = x in x - -geFloat# :: Float# -> Float# -> Bool -geFloat# = let x = x in x - -eqFloat# :: Float# -> Float# -> Bool -eqFloat# = let x = x in x - -neFloat# :: Float# -> Float# -> Bool -neFloat# = let x = x in x - -ltFloat# :: Float# -> Float# -> Bool -ltFloat# = let x = x in x - -leFloat# :: Float# -> Float# -> Bool -leFloat# = let x = x in x - -plusFloat# :: Float# -> Float# -> Float# -plusFloat# = let x = x in x - -minusFloat# :: Float# -> Float# -> Float# -minusFloat# = let x = x in x - -timesFloat# :: Float# -> Float# -> Float# -timesFloat# = let x = x in x - -divideFloat# :: Float# -> Float# -> Float# -divideFloat# = let x = x in x - -negateFloat# :: Float# -> Float# -negateFloat# = let x = x in x - --- |Truncates a @Float#@ value to the nearest @Int#@. --- Results are undefined if the truncation if truncation yields --- a value outside the range of @Int#@. - -float2Int# :: Float# -> Int# -float2Int# = let x = x in x - -expFloat# :: Float# -> Float# -expFloat# = let x = x in x - -logFloat# :: Float# -> Float# -logFloat# = let x = x in x - -sqrtFloat# :: Float# -> Float# -sqrtFloat# = let x = x in x - -sinFloat# :: Float# -> Float# -sinFloat# = let x = x in x - -cosFloat# :: Float# -> Float# -cosFloat# = let x = x in x - -tanFloat# :: Float# -> Float# -tanFloat# = let x = x in x - -asinFloat# :: Float# -> Float# -asinFloat# = let x = x in x - -acosFloat# :: Float# -> Float# -acosFloat# = let x = x in x - -atanFloat# :: Float# -> Float# -atanFloat# = let x = x in x - -sinhFloat# :: Float# -> Float# -sinhFloat# = let x = x in x - -coshFloat# :: Float# -> Float# -coshFloat# = let x = x in x - -tanhFloat# :: Float# -> Float# -tanhFloat# = let x = x in x - -powerFloat# :: Float# -> Float# -> Float# -powerFloat# = let x = x in x - -float2Double# :: Float# -> Double# -float2Double# = let x = x in x - --- |Convert to arbitrary-precision integer. --- First @Int\#@ in result is the exponent; second @Int\#@ and @ByteArray\#@ --- represent an @Integer\#@ holding the mantissa. - -decodeFloat# :: Float# -> (# Int#,Int#,ByteArray# #) -decodeFloat# = let x = x in x - --- |Convert to arbitrary-precision integer. --- First @Int\#@ in result is the mantissa; second is the exponent. - -decodeFloat_Int# :: Float# -> (# Int#,Int# #) -decodeFloat_Int# = let x = x in x - -data Array# a - -data MutableArray# s a - --- |Create a new mutable array of specified size (in bytes), --- in the specified state thread, --- with each element containing the specified initial value. - -newArray# :: Int# -> a -> State# s -> (# State# s,MutableArray# s a #) -newArray# = let x = x in x - -sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool -sameMutableArray# = let x = x in x - --- |Read from specified index of mutable array. Result is not yet evaluated. - -readArray# :: MutableArray# s a -> Int# -> State# s -> (# State# s,a #) -readArray# = let x = x in x - --- |Write to specified index of mutable array. - -writeArray# :: MutableArray# s a -> Int# -> a -> State# s -> State# s -writeArray# = let x = x in x - --- |Read from specified index of immutable array. Result is packaged into --- an unboxed singleton; the result itself is not yet evaluated. - -indexArray# :: Array# a -> Int# -> (# a #) -indexArray# = let x = x in x - --- |Make a mutable array immutable, without copying. - -unsafeFreezeArray# :: MutableArray# s a -> State# s -> (# State# s,Array# a #) -unsafeFreezeArray# = let x = x in x - --- |Make an immutable array mutable, without copying. - -unsafeThawArray# :: Array# a -> State# s -> (# State# s,MutableArray# s a #) -unsafeThawArray# = let x = x in x - -data ByteArray# - -data MutableByteArray# s - --- |Create a new mutable byte array of specified size (in bytes), in --- the specified state thread. - -newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #) -newByteArray# = let x = x in x - --- |Create a mutable byte array that the GC guarantees not to move. - -newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #) -newPinnedByteArray# = let x = x in x - --- |Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move. - -newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #) -newAlignedPinnedByteArray# = let x = x in x - --- |Intended for use with pinned arrays; otherwise very unsafe! - -byteArrayContents# :: ByteArray# -> Addr# -byteArrayContents# = let x = x in x - -sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool -sameMutableByteArray# = let x = x in x - --- |Make a mutable byte array immutable, without copying. - -unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #) -unsafeFreezeByteArray# = let x = x in x - -sizeofByteArray# :: ByteArray# -> Int# -sizeofByteArray# = let x = x in x - -sizeofMutableByteArray# :: MutableByteArray# s -> Int# -sizeofMutableByteArray# = let x = x in x - --- |Read 8-bit character; offset in bytes. - -indexCharArray# :: ByteArray# -> Int# -> Char# -indexCharArray# = let x = x in x - --- |Read 31-bit character; offset in 4-byte words. - -indexWideCharArray# :: ByteArray# -> Int# -> Char# -indexWideCharArray# = let x = x in x - -indexIntArray# :: ByteArray# -> Int# -> Int# -indexIntArray# = let x = x in x - -indexWordArray# :: ByteArray# -> Int# -> Word# -indexWordArray# = let x = x in x - -indexAddrArray# :: ByteArray# -> Int# -> Addr# -indexAddrArray# = let x = x in x - -indexFloatArray# :: ByteArray# -> Int# -> Float# -indexFloatArray# = let x = x in x - -indexDoubleArray# :: ByteArray# -> Int# -> Double# -indexDoubleArray# = let x = x in x - -indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a -indexStablePtrArray# = let x = x in x - -indexInt8Array# :: ByteArray# -> Int# -> Int# -indexInt8Array# = let x = x in x - -indexInt16Array# :: ByteArray# -> Int# -> Int# -indexInt16Array# = let x = x in x - -indexInt32Array# :: ByteArray# -> Int# -> Int# -indexInt32Array# = let x = x in x - -indexInt64Array# :: ByteArray# -> Int# -> Int# -indexInt64Array# = let x = x in x - -indexWord8Array# :: ByteArray# -> Int# -> Word# -indexWord8Array# = let x = x in x - -indexWord16Array# :: ByteArray# -> Int# -> Word# -indexWord16Array# = let x = x in x - -indexWord32Array# :: ByteArray# -> Int# -> Word# -indexWord32Array# = let x = x in x - -indexWord64Array# :: ByteArray# -> Int# -> Word# -indexWord64Array# = let x = x in x - --- |Read 8-bit character; offset in bytes. - -readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #) -readCharArray# = let x = x in x - --- |Read 31-bit character; offset in 4-byte words. - -readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #) -readWideCharArray# = let x = x in x - -readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) -readIntArray# = let x = x in x - -readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) -readWordArray# = let x = x in x - -readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #) -readAddrArray# = let x = x in x - -readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #) -readFloatArray# = let x = x in x - -readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #) -readDoubleArray# = let x = x in x - -readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #) -readStablePtrArray# = let x = x in x - -readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) -readInt8Array# = let x = x in x - -readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) -readInt16Array# = let x = x in x - -readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) -readInt32Array# = let x = x in x - -readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) -readInt64Array# = let x = x in x - -readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) -readWord8Array# = let x = x in x - -readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) -readWord16Array# = let x = x in x - -readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) -readWord32Array# = let x = x in x - -readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) -readWord64Array# = let x = x in x - --- |Write 8-bit character; offset in bytes. - -writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s -writeCharArray# = let x = x in x - --- |Write 31-bit character; offset in 4-byte words. - -writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s -writeWideCharArray# = let x = x in x - -writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -writeIntArray# = let x = x in x - -writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s -writeWordArray# = let x = x in x - -writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s -writeAddrArray# = let x = x in x - -writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s -writeFloatArray# = let x = x in x - -writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s -writeDoubleArray# = let x = x in x - -writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s -writeStablePtrArray# = let x = x in x - -writeInt8Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -writeInt8Array# = let x = x in x - -writeInt16Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -writeInt16Array# = let x = x in x - -writeInt32Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -writeInt32Array# = let x = x in x - -writeInt64Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -writeInt64Array# = let x = x in x - -writeWord8Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s -writeWord8Array# = let x = x in x - -writeWord16Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s -writeWord16Array# = let x = x in x - -writeWord32Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s -writeWord32Array# = let x = x in x - -writeWord64Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s -writeWord64Array# = let x = x in x - --- | An arbitrary machine address assumed to point outside --- the garbage-collected heap. - -data Addr# - --- | The null address. - -nullAddr# :: Addr# -nullAddr# = let x = x in x - -plusAddr# :: Addr# -> Int# -> Addr# -plusAddr# = let x = x in x - --- |Result is meaningless if two @Addr\#@s are so far apart that their --- difference doesn\'t fit in an @Int\#@. - -minusAddr# :: Addr# -> Addr# -> Int# -minusAddr# = let x = x in x - --- |Return the remainder when the @Addr\#@ arg, treated like an @Int\#@, --- is divided by the @Int\#@ arg. - -remAddr# :: Addr# -> Int# -> Int# -remAddr# = let x = x in x - --- |Coerce directly from address to int. Strongly deprecated. - -addr2Int# :: Addr# -> Int# -addr2Int# = let x = x in x - --- |Coerce directly from int to address. Strongly deprecated. - -int2Addr# :: Int# -> Addr# -int2Addr# = let x = x in x - -gtAddr# :: Addr# -> Addr# -> Bool -gtAddr# = let x = x in x - -geAddr# :: Addr# -> Addr# -> Bool -geAddr# = let x = x in x - -eqAddr# :: Addr# -> Addr# -> Bool -eqAddr# = let x = x in x - -neAddr# :: Addr# -> Addr# -> Bool -neAddr# = let x = x in x - -ltAddr# :: Addr# -> Addr# -> Bool -ltAddr# = let x = x in x - -leAddr# :: Addr# -> Addr# -> Bool -leAddr# = let x = x in x - --- |Reads 8-bit character; offset in bytes. - -indexCharOffAddr# :: Addr# -> Int# -> Char# -indexCharOffAddr# = let x = x in x - --- |Reads 31-bit character; offset in 4-byte words. - -indexWideCharOffAddr# :: Addr# -> Int# -> Char# -indexWideCharOffAddr# = let x = x in x - -indexIntOffAddr# :: Addr# -> Int# -> Int# -indexIntOffAddr# = let x = x in x - -indexWordOffAddr# :: Addr# -> Int# -> Word# -indexWordOffAddr# = let x = x in x - -indexAddrOffAddr# :: Addr# -> Int# -> Addr# -indexAddrOffAddr# = let x = x in x - -indexFloatOffAddr# :: Addr# -> Int# -> Float# -indexFloatOffAddr# = let x = x in x - -indexDoubleOffAddr# :: Addr# -> Int# -> Double# -indexDoubleOffAddr# = let x = x in x - -indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -indexStablePtrOffAddr# = let x = x in x - -indexInt8OffAddr# :: Addr# -> Int# -> Int# -indexInt8OffAddr# = let x = x in x - -indexInt16OffAddr# :: Addr# -> Int# -> Int# -indexInt16OffAddr# = let x = x in x - -indexInt32OffAddr# :: Addr# -> Int# -> Int# -indexInt32OffAddr# = let x = x in x - -indexInt64OffAddr# :: Addr# -> Int# -> Int# -indexInt64OffAddr# = let x = x in x - -indexWord8OffAddr# :: Addr# -> Int# -> Word# -indexWord8OffAddr# = let x = x in x - -indexWord16OffAddr# :: Addr# -> Int# -> Word# -indexWord16OffAddr# = let x = x in x - -indexWord32OffAddr# :: Addr# -> Int# -> Word# -indexWord32OffAddr# = let x = x in x - -indexWord64OffAddr# :: Addr# -> Int# -> Word# -indexWord64OffAddr# = let x = x in x - --- |Reads 8-bit character; offset in bytes. - -readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #) -readCharOffAddr# = let x = x in x - --- |Reads 31-bit character; offset in 4-byte words. - -readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #) -readWideCharOffAddr# = let x = x in x - -readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) -readIntOffAddr# = let x = x in x - -readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) -readWordOffAddr# = let x = x in x - -readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #) -readAddrOffAddr# = let x = x in x - -readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #) -readFloatOffAddr# = let x = x in x - -readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #) -readDoubleOffAddr# = let x = x in x - -readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #) -readStablePtrOffAddr# = let x = x in x - -readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) -readInt8OffAddr# = let x = x in x - -readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) -readInt16OffAddr# = let x = x in x - -readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) -readInt32OffAddr# = let x = x in x - -readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) -readInt64OffAddr# = let x = x in x - -readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) -readWord8OffAddr# = let x = x in x - -readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) -readWord16OffAddr# = let x = x in x - -readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) -readWord32OffAddr# = let x = x in x - -readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) -readWord64OffAddr# = let x = x in x - -writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s -writeCharOffAddr# = let x = x in x - -writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s -writeWideCharOffAddr# = let x = x in x - -writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s -writeIntOffAddr# = let x = x in x - -writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s -writeWordOffAddr# = let x = x in x - -writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s -writeAddrOffAddr# = let x = x in x - -writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s -writeFloatOffAddr# = let x = x in x - -writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s -writeDoubleOffAddr# = let x = x in x - -writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s -writeStablePtrOffAddr# = let x = x in x - -writeInt8OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s -writeInt8OffAddr# = let x = x in x - -writeInt16OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s -writeInt16OffAddr# = let x = x in x - -writeInt32OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s -writeInt32OffAddr# = let x = x in x - -writeInt64OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s -writeInt64OffAddr# = let x = x in x - -writeWord8OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s -writeWord8OffAddr# = let x = x in x - -writeWord16OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s -writeWord16OffAddr# = let x = x in x - -writeWord32OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s -writeWord32OffAddr# = let x = x in x - -writeWord64OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s -writeWord64OffAddr# = let x = x in x - --- |A @MutVar\#@ behaves like a single-element mutable array. - -data MutVar# s a - --- |Create @MutVar\#@ with specified initial value in specified state thread. - -newMutVar# :: a -> State# s -> (# State# s,MutVar# s a #) -newMutVar# = let x = x in x - --- |Read contents of @MutVar\#@. Result is not yet evaluated. - -readMutVar# :: MutVar# s a -> State# s -> (# State# s,a #) -readMutVar# = let x = x in x - --- |Write contents of @MutVar\#@. - -writeMutVar# :: MutVar# s a -> a -> State# s -> State# s -writeMutVar# = let x = x in x - -sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool -sameMutVar# = let x = x in x - -atomicModifyMutVar# :: MutVar# s a -> (a -> b) -> State# s -> (# State# s,c #) -atomicModifyMutVar# = let x = x in x - -catch# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #) -catch# = let x = x in x - -raise# :: a -> b -raise# = let x = x in x - -raiseIO# :: a -> State# (RealWorld) -> (# State# (RealWorld),b #) -raiseIO# = let x = x in x - -blockAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #) -blockAsyncExceptions# = let x = x in x - -unblockAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #) -unblockAsyncExceptions# = let x = x in x - -asyncExceptionsBlocked# :: State# (RealWorld) -> (# State# (RealWorld),Int# #) -asyncExceptionsBlocked# = let x = x in x - -data TVar# s a - -atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #) -atomically# = let x = x in x - -retry# :: State# (RealWorld) -> (# State# (RealWorld),a #) -retry# = let x = x in x - -catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #) -catchRetry# = let x = x in x - -catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #) -catchSTM# = let x = x in x - -check# :: (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),() #) -check# = let x = x in x - --- |Create a new @TVar\#@ holding a specified initial value. - -newTVar# :: a -> State# s -> (# State# s,TVar# s a #) -newTVar# = let x = x in x - --- |Read contents of @TVar\#@. Result is not yet evaluated. - -readTVar# :: TVar# s a -> State# s -> (# State# s,a #) -readTVar# = let x = x in x - --- |Write contents of @TVar\#@. - -writeTVar# :: TVar# s a -> a -> State# s -> State# s -writeTVar# = let x = x in x - -sameTVar# :: TVar# s a -> TVar# s a -> Bool -sameTVar# = let x = x in x - --- | A shared mutable variable (/not/ the same as a @MutVar\#@!). --- (Note: in a non-concurrent implementation, @(MVar\# a)@ can be --- represented by @(MutVar\# (Maybe a))@.) - -data MVar# s a - --- |Create new @MVar\#@; initially empty. - -newMVar# :: State# s -> (# State# s,MVar# s a #) -newMVar# = let x = x in x - --- |If @MVar\#@ is empty, block until it becomes full. --- Then remove and return its contents, and set it empty. - -takeMVar# :: MVar# s a -> State# s -> (# State# s,a #) -takeMVar# = let x = x in x - --- |If @MVar\#@ is empty, immediately return with integer 0 and value undefined. --- Otherwise, return with integer 1 and contents of @MVar\#@, and set @MVar\#@ empty. - -tryTakeMVar# :: MVar# s a -> State# s -> (# State# s,Int#,a #) -tryTakeMVar# = let x = x in x - --- |If @MVar\#@ is full, block until it becomes empty. --- Then store value arg as its new contents. - -putMVar# :: MVar# s a -> a -> State# s -> State# s -putMVar# = let x = x in x - --- |If @MVar\#@ is full, immediately return with integer 0. --- Otherwise, store value arg as @MVar\#@\'s new contents, and return with integer 1. - -tryPutMVar# :: MVar# s a -> a -> State# s -> (# State# s,Int# #) -tryPutMVar# = let x = x in x - -sameMVar# :: MVar# s a -> MVar# s a -> Bool -sameMVar# = let x = x in x - --- |Return 1 if @MVar\#@ is empty; 0 otherwise. - -isEmptyMVar# :: MVar# s a -> State# s -> (# State# s,Int# #) -isEmptyMVar# = let x = x in x - --- |Sleep specified number of microseconds. - -delay# :: Int# -> State# s -> State# s -delay# = let x = x in x - --- |Block until input is available on specified file descriptor. - -waitRead# :: Int# -> State# s -> State# s -waitRead# = let x = x in x - --- |Block until output is possible on specified file descriptor. - -waitWrite# :: Int# -> State# s -> State# s -waitWrite# = let x = x in x - --- | @State\#@ is the primitive, unlifted type of states. It has --- one type parameter, thus @State\# RealWorld@, or @State\# s@, --- where s is a type variable. The only purpose of the type parameter --- is to keep different state threads separate. It is represented by --- nothing at all. - -data State# s - --- | @RealWorld@ is deeply magical. It is /primitive/, but it is not --- /unlifted/ (hence @ptrArg@). We never manipulate values of type --- @RealWorld@; it\'s only used in the type system, to parameterise @State\#@. - -data RealWorld - --- |(In a non-concurrent implementation, this can be a singleton --- type, whose (unique) value is returned by @myThreadId\#@. The --- other operations can be omitted.) - -data ThreadId# - -fork# :: a -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #) -fork# = let x = x in x - -forkOn# :: Int# -> a -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #) -forkOn# = let x = x in x - -killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld) -killThread# = let x = x in x - -yield# :: State# (RealWorld) -> State# (RealWorld) -yield# = let x = x in x - -myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #) -myThreadId# = let x = x in x - -labelThread# :: ThreadId# -> Addr# -> State# (RealWorld) -> State# (RealWorld) -labelThread# = let x = x in x - -isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #) -isCurrentThreadBound# = let x = x in x - -noDuplicate# :: State# (RealWorld) -> State# (RealWorld) -noDuplicate# = let x = x in x - -threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int# #) -threadStatus# = let x = x in x - -data Weak# b - -mkWeak# :: o -> b -> c -> State# (RealWorld) -> (# State# (RealWorld),Weak# b #) -mkWeak# = let x = x in x - -mkWeakForeignEnv# :: o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Weak# b #) -mkWeakForeignEnv# = let x = x in x - -deRefWeak# :: Weak# a -> State# (RealWorld) -> (# State# (RealWorld),Int#,a #) -deRefWeak# = let x = x in x - -finalizeWeak# :: Weak# a -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),() #) #) -finalizeWeak# = let x = x in x - -touch# :: o -> State# (RealWorld) -> State# (RealWorld) -touch# = let x = x in x - -data StablePtr# a - -data StableName# a - -makeStablePtr# :: a -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a #) -makeStablePtr# = let x = x in x - -deRefStablePtr# :: StablePtr# a -> State# (RealWorld) -> (# State# (RealWorld),a #) -deRefStablePtr# = let x = x in x - -eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# -eqStablePtr# = let x = x in x - -makeStableName# :: a -> State# (RealWorld) -> (# State# (RealWorld),StableName# a #) -makeStableName# = let x = x in x - -eqStableName# :: StableName# a -> StableName# a -> Int# -eqStableName# = let x = x in x - -stableNameToInt# :: StableName# a -> Int# -stableNameToInt# = let x = x in x - -reallyUnsafePtrEquality# :: a -> a -> Int# -reallyUnsafePtrEquality# = let x = x in x - -par# :: a -> Int# -par# = let x = x in x - -parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int# -parGlobal# = let x = x in x - -parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int# -parLocal# = let x = x in x - -parAt# :: b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# -parAt# = let x = x in x - -parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# -parAtAbs# = let x = x in x - -parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# -parAtRel# = let x = x in x - -parAtForNow# :: b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# -parAtForNow# = let x = x in x - -dataToTag# :: a -> Int# -dataToTag# = let x = x in x - -tagToEnum# :: Int# -> a -tagToEnum# = let x = x in x - --- |Primitive bytecode type. - -data BCO# - --- |Convert an @Addr\#@ to a followable type. - -addrToHValue# :: Addr# -> (# a #) -addrToHValue# = let x = x in x - -mkApUpd0# :: BCO# -> (# a #) -mkApUpd0# = let x = x in x - -newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO# #) -newBCO# = let x = x in x - -unpackClosure# :: a -> (# Addr#,Array# b,ByteArray# #) -unpackClosure# = let x = x in x - -getApStackVal# :: a -> Int# -> (# Int#,b #) -getApStackVal# = let x = x in x - --- | Evaluates its first argument to head normal form, and then returns its second --- argument as the result. - -seq :: a -> b -> b -seq = let x = x in x - --- | The call @(inline f)@ arranges that f is inlined, regardless of its size. --- More precisely, the call @(inline f)@ rewrites to the right-hand side of --- @f@\'s definition. This allows the programmer to control inlining from a --- particular call site rather than the definition site of the function (c.f. --- @INLINE@ pragmas in User\'s Guide, Section 7.10.3, \"INLINE and NOINLINE --- pragmas\"). --- --- This inlining occurs regardless of the argument to the call or the size of --- @f@\'s definition; it is unconditional. The main caveat is that @f@\'s --- definition must be visible to the compiler. That is, @f@ must be --- @let@-bound in the current scope. If no inlining takes place, the --- @inline@ function expands to the identity function in Phase zero; so its --- use imposes no overhead. --- --- If the function is defined in another module, GHC only exposes its inlining --- in the interface file if the function is sufficiently small that it might be --- inlined by the automatic mechanism. There is currently no way to tell GHC to --- expose arbitrarily-large functions in the interface file. (This shortcoming --- is something that could be fixed, with some kind of pragma.) - -inline :: a -> a -inline = let x = x in x - --- | The @lazy@ function restrains strictness analysis a little. The call --- @(lazy e)@ means the same as @e@, but @lazy@ has a magical --- property so far as strictness analysis is concerned: it is lazy in its first --- argument, even though its semantics is strict. After strictness analysis has --- run, calls to @lazy@ are inlined to be the identity function. --- --- This behaviour is occasionally useful when controlling evaluation order. --- Notably, @lazy@ is used in the library definition of @Control.Parallel.par@: --- --- @par :: a -> b -> b@ --- --- @par x y = case (par\# x) of \_ -> lazy y@ --- --- If @lazy@ were not lazy, @par@ would look strict in @y@ which --- would defeat the whole purpose of @par@. --- --- Like @seq@, the argument of @lazy@ can have an unboxed type. - -lazy :: a -> a -lazy = let x = x in x - --- | The type constructor @Any@ is type to which you can unsafely coerce any --- lifted type, and back. --- --- * It is lifted, and hence represented by a pointer --- --- * It does not claim to be a /data/ type, and that\'s important for --- the code generator, because the code gen may /enter/ a data value --- but never enters a function value. --- --- It\'s also used to instantiate un-constrained type variables after type --- checking. For example --- --- @length Any []@ --- --- Annoyingly, we sometimes need @Any@s of other kinds, such as @(* -> *)@ etc. --- This is a bit like tuples. We define a couple of useful ones here, --- and make others up on the fly. If any of these others end up being exported --- into interface files, we\'ll get a crash; at least until we add interface-file --- syntax to support them. - -data Any a - --- | The function @unsafeCoerce\#@ allows you to side-step the typechecker entirely. That --- is, it allows you to coerce any type into any other type. If you use this function, --- you had better get it right, otherwise segmentation faults await. It is generally --- used when you want to write a program that you know is well-typed, but where Haskell\'s --- type system is not expressive enough to prove that it is well typed. --- --- The following uses of @unsafeCoerce\#@ are supposed to work (i.e. not lead to --- spurious compile-time or run-time crashes): --- --- * Casting any lifted type to @Any@ --- --- * Casting @Any@ back to the real type --- --- * Casting an unboxed type to another unboxed type of the same size --- (but not coercions between floating-point and integral types) --- --- * Casting between two types that have the same runtime representation. One case is when --- the two types differ only in \"phantom\" type parameters, for example --- @Ptr Int@ to @Ptr Float@, or @[Int]@ to @[Float]@ when the list is --- known to be empty. Also, a @newtype@ of a type @T@ has the same representation --- at runtime as @T@. --- --- Other uses of @unsafeCoerce\#@ are undefined. In particular, you should not use --- @unsafeCoerce\#@ to cast a T to an algebraic data type D, unless T is also --- an algebraic data type. For example, do not cast @Int->Int@ to @Bool@, even if --- you later cast that @Bool@ back to @Int->Int@ before applying it. The reasons --- have to do with GHC\'s internal representation details (for the congnoscenti, data values --- can be entered but function closures cannot). If you want a safe type to cast things --- to, use @Any@, which is not an algebraic data type. --- --- - -unsafeCoerce# :: a -> b -unsafeCoerce# = let x = x in x - - - diff --git a/lib/ghc-prim/GHC/PrimopWrappers.hs b/lib/ghc-prim/GHC/PrimopWrappers.hs --- a/lib/ghc-prim/GHC/PrimopWrappers.hs +++ b/lib/ghc-prim/GHC/PrimopWrappers.hs @@ -1,20 +1,9 @@ -{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, CPP #-} +{-# LANGUAGE NoImplicitPrelude, UnboxedTuples #-} module GHC.PrimopWrappers where import qualified GHC.Prim import GHC.Bool (Bool) import GHC.Unit () -import GHC.Prim (Char#, Int#, Word#, Int64#, Word64#, Float#, Double#, ByteArray#, State#, MutableArray#, Array#, MutableByteArray#, Addr#, StablePtr#, MutVar#, RealWorld, TVar#, MVar#, ThreadId#, Weak#, StableName#, BCO#) - - -#if WORD_SIZE == 4 -#define INT64 Int64# -#define WORD64 Word64# -#elif WORD_SIZE == 8 -#define INT64 Int# -#define WORD64 Word# -#endif - - +import GHC.Prim (Char#, Int#, Word#, Float#, Double#, State#, MutableArray#, Array#, MutableByteArray#, ByteArray#, Addr#, StablePtr#, MutVar#, RealWorld, TVar#, MVar#, ThreadId#, Weak#, StableName#, BCO#) {-# NOINLINE gtChar# #-} gtChar# :: Char# -> Char# -> Bool gtChar# a1 a2 = (GHC.Prim.gtChar#) a1 a2 @@ -54,9 +43,6 @@ {-# NOINLINE remInt# #-} remInt# :: Int# -> Int# -> Int# remInt# a1 a2 = (GHC.Prim.remInt#) a1 a2 -{-# NOINLINE gcdInt# #-} -gcdInt# :: Int# -> Int# -> Int# -gcdInt# a1 a2 = (GHC.Prim.gcdInt#) a1 a2 {-# NOINLINE negateInt# #-} negateInt# :: Int# -> Int# negateInt# a1 = (GHC.Prim.negateInt#) a1 @@ -96,9 +82,6 @@ {-# NOINLINE int2Double# #-} int2Double# :: Int# -> Double# int2Double# a1 = (GHC.Prim.int2Double#) a1 -{-# NOINLINE int2Integer# #-} -int2Integer# :: Int# -> (# Int#,ByteArray# #) -int2Integer# a1 = (GHC.Prim.int2Integer#) a1 {-# NOINLINE uncheckedIShiftL# #-} uncheckedIShiftL# :: Int# -> Int# -> Int# uncheckedIShiftL# a1 a2 = (GHC.Prim.uncheckedIShiftL#) a1 a2 @@ -144,9 +127,6 @@ {-# NOINLINE word2Int# #-} word2Int# :: Word# -> Int# word2Int# a1 = (GHC.Prim.word2Int#) a1 -{-# NOINLINE word2Integer# #-} -word2Integer# :: Word# -> (# Int#,ByteArray# #) -word2Integer# a1 = (GHC.Prim.word2Integer#) a1 {-# NOINLINE gtWord# #-} gtWord# :: Word# -> Word# -> Bool gtWord# a1 a2 = (GHC.Prim.gtWord#) a1 a2 @@ -183,60 +163,6 @@ {-# NOINLINE narrow32Word# #-} narrow32Word# :: Word# -> Word# narrow32Word# a1 = (GHC.Prim.narrow32Word#) a1 -{-# NOINLINE plusInteger# #-} -plusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -plusInteger# a1 a2 a3 a4 = (GHC.Prim.plusInteger#) a1 a2 a3 a4 -{-# NOINLINE minusInteger# #-} -minusInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -minusInteger# a1 a2 a3 a4 = (GHC.Prim.minusInteger#) a1 a2 a3 a4 -{-# NOINLINE timesInteger# #-} -timesInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -timesInteger# a1 a2 a3 a4 = (GHC.Prim.timesInteger#) a1 a2 a3 a4 -{-# NOINLINE gcdInteger# #-} -gcdInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -gcdInteger# a1 a2 a3 a4 = (GHC.Prim.gcdInteger#) a1 a2 a3 a4 -{-# NOINLINE gcdIntegerInt# #-} -gcdIntegerInt# :: Int# -> ByteArray# -> Int# -> Int# -gcdIntegerInt# a1 a2 a3 = (GHC.Prim.gcdIntegerInt#) a1 a2 a3 -{-# NOINLINE divExactInteger# #-} -divExactInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -divExactInteger# a1 a2 a3 a4 = (GHC.Prim.divExactInteger#) a1 a2 a3 a4 -{-# NOINLINE quotInteger# #-} -quotInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -quotInteger# a1 a2 a3 a4 = (GHC.Prim.quotInteger#) a1 a2 a3 a4 -{-# NOINLINE remInteger# #-} -remInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -remInteger# a1 a2 a3 a4 = (GHC.Prim.remInteger#) a1 a2 a3 a4 -{-# NOINLINE cmpInteger# #-} -cmpInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int# -cmpInteger# a1 a2 a3 a4 = (GHC.Prim.cmpInteger#) a1 a2 a3 a4 -{-# NOINLINE cmpIntegerInt# #-} -cmpIntegerInt# :: Int# -> ByteArray# -> Int# -> Int# -cmpIntegerInt# a1 a2 a3 = (GHC.Prim.cmpIntegerInt#) a1 a2 a3 -{-# NOINLINE quotRemInteger# #-} -quotRemInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #) -quotRemInteger# a1 a2 a3 a4 = (GHC.Prim.quotRemInteger#) a1 a2 a3 a4 -{-# NOINLINE divModInteger# #-} -divModInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray#,Int#,ByteArray# #) -divModInteger# a1 a2 a3 a4 = (GHC.Prim.divModInteger#) a1 a2 a3 a4 -{-# NOINLINE integer2Int# #-} -integer2Int# :: Int# -> ByteArray# -> Int# -integer2Int# a1 a2 = (GHC.Prim.integer2Int#) a1 a2 -{-# NOINLINE integer2Word# #-} -integer2Word# :: Int# -> ByteArray# -> Word# -integer2Word# a1 a2 = (GHC.Prim.integer2Word#) a1 a2 -{-# NOINLINE andInteger# #-} -andInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -andInteger# a1 a2 a3 a4 = (GHC.Prim.andInteger#) a1 a2 a3 a4 -{-# NOINLINE orInteger# #-} -orInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -orInteger# a1 a2 a3 a4 = (GHC.Prim.orInteger#) a1 a2 a3 a4 -{-# NOINLINE xorInteger# #-} -xorInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#,ByteArray# #) -xorInteger# a1 a2 a3 a4 = (GHC.Prim.xorInteger#) a1 a2 a3 a4 -{-# NOINLINE complementInteger# #-} -complementInteger# :: Int# -> ByteArray# -> (# Int#,ByteArray# #) -complementInteger# a1 a2 = (GHC.Prim.complementInteger#) a1 a2 {-# NOINLINE (>##) #-} (>##) :: Double# -> Double# -> Bool (>##) a1 a2 = (GHC.Prim.>##) a1 a2 @@ -315,9 +241,6 @@ {-# NOINLINE (**##) #-} (**##) :: Double# -> Double# -> Double# (**##) a1 a2 = (GHC.Prim.**##) a1 a2 -{-# NOINLINE decodeDouble# #-} -decodeDouble# :: Double# -> (# Int#,Int#,ByteArray# #) -decodeDouble# a1 = (GHC.Prim.decodeDouble#) a1 {-# NOINLINE decodeDouble_2Int# #-} decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #) decodeDouble_2Int# a1 = (GHC.Prim.decodeDouble_2Int#) a1 @@ -399,9 +322,6 @@ {-# NOINLINE float2Double# #-} float2Double# :: Float# -> Double# float2Double# a1 = (GHC.Prim.float2Double#) a1 -{-# NOINLINE decodeFloat# #-} -decodeFloat# :: Float# -> (# Int#,Int#,ByteArray# #) -decodeFloat# a1 = (GHC.Prim.decodeFloat#) a1 {-# NOINLINE decodeFloat_Int# #-} decodeFloat_Int# :: Float# -> (# Int#,Int# #) decodeFloat_Int# a1 = (GHC.Prim.decodeFloat_Int#) a1 @@ -484,7 +404,7 @@ indexInt32Array# :: ByteArray# -> Int# -> Int# indexInt32Array# a1 a2 = (GHC.Prim.indexInt32Array#) a1 a2 {-# NOINLINE indexInt64Array# #-} -indexInt64Array# :: ByteArray# -> Int# -> INT64 +indexInt64Array# :: ByteArray# -> Int# -> Int# indexInt64Array# a1 a2 = (GHC.Prim.indexInt64Array#) a1 a2 {-# NOINLINE indexWord8Array# #-} indexWord8Array# :: ByteArray# -> Int# -> Word# @@ -496,7 +416,7 @@ indexWord32Array# :: ByteArray# -> Int# -> Word# indexWord32Array# a1 a2 = (GHC.Prim.indexWord32Array#) a1 a2 {-# NOINLINE indexWord64Array# #-} -indexWord64Array# :: ByteArray# -> Int# -> WORD64 +indexWord64Array# :: ByteArray# -> Int# -> Word# indexWord64Array# a1 a2 = (GHC.Prim.indexWord64Array#) a1 a2 {-# NOINLINE readCharArray# #-} readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #) @@ -532,7 +452,7 @@ readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) readInt32Array# a1 a2 a3 = (GHC.Prim.readInt32Array#) a1 a2 a3 {-# NOINLINE readInt64Array# #-} -readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,INT64 #) +readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) readInt64Array# a1 a2 a3 = (GHC.Prim.readInt64Array#) a1 a2 a3 {-# NOINLINE readWord8Array# #-} readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) @@ -544,7 +464,7 @@ readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) readWord32Array# a1 a2 a3 = (GHC.Prim.readWord32Array#) a1 a2 a3 {-# NOINLINE readWord64Array# #-} -readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,WORD64 #) +readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #) readWord64Array# a1 a2 a3 = (GHC.Prim.readWord64Array#) a1 a2 a3 {-# NOINLINE writeCharArray# #-} writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s @@ -580,7 +500,7 @@ writeInt32Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s writeInt32Array# a1 a2 a3 a4 = (GHC.Prim.writeInt32Array#) a1 a2 a3 a4 {-# NOINLINE writeInt64Array# #-} -writeInt64Array# :: MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s +writeInt64Array# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s writeInt64Array# a1 a2 a3 a4 = (GHC.Prim.writeInt64Array#) a1 a2 a3 a4 {-# NOINLINE writeWord8Array# #-} writeWord8Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s @@ -592,7 +512,7 @@ writeWord32Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s writeWord32Array# a1 a2 a3 a4 = (GHC.Prim.writeWord32Array#) a1 a2 a3 a4 {-# NOINLINE writeWord64Array# #-} -writeWord64Array# :: MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s +writeWord64Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s writeWord64Array# a1 a2 a3 a4 = (GHC.Prim.writeWord64Array#) a1 a2 a3 a4 {-# NOINLINE plusAddr# #-} plusAddr# :: Addr# -> Int# -> Addr# @@ -661,7 +581,7 @@ indexInt32OffAddr# :: Addr# -> Int# -> Int# indexInt32OffAddr# a1 a2 = (GHC.Prim.indexInt32OffAddr#) a1 a2 {-# NOINLINE indexInt64OffAddr# #-} -indexInt64OffAddr# :: Addr# -> Int# -> INT64 +indexInt64OffAddr# :: Addr# -> Int# -> Int# indexInt64OffAddr# a1 a2 = (GHC.Prim.indexInt64OffAddr#) a1 a2 {-# NOINLINE indexWord8OffAddr# #-} indexWord8OffAddr# :: Addr# -> Int# -> Word# @@ -673,7 +593,7 @@ indexWord32OffAddr# :: Addr# -> Int# -> Word# indexWord32OffAddr# a1 a2 = (GHC.Prim.indexWord32OffAddr#) a1 a2 {-# NOINLINE indexWord64OffAddr# #-} -indexWord64OffAddr# :: Addr# -> Int# -> WORD64 +indexWord64OffAddr# :: Addr# -> Int# -> Word# indexWord64OffAddr# a1 a2 = (GHC.Prim.indexWord64OffAddr#) a1 a2 {-# NOINLINE readCharOffAddr# #-} readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #) @@ -709,7 +629,7 @@ readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) readInt32OffAddr# a1 a2 a3 = (GHC.Prim.readInt32OffAddr#) a1 a2 a3 {-# NOINLINE readInt64OffAddr# #-} -readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,INT64 #) +readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #) readInt64OffAddr# a1 a2 a3 = (GHC.Prim.readInt64OffAddr#) a1 a2 a3 {-# NOINLINE readWord8OffAddr# #-} readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) @@ -721,7 +641,7 @@ readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) readWord32OffAddr# a1 a2 a3 = (GHC.Prim.readWord32OffAddr#) a1 a2 a3 {-# NOINLINE readWord64OffAddr# #-} -readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,WORD64 #) +readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #) readWord64OffAddr# a1 a2 a3 = (GHC.Prim.readWord64OffAddr#) a1 a2 a3 {-# NOINLINE writeCharOffAddr# #-} writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s @@ -757,7 +677,7 @@ writeInt32OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s writeInt32OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeInt32OffAddr#) a1 a2 a3 a4 {-# NOINLINE writeInt64OffAddr# #-} -writeInt64OffAddr# :: Addr# -> Int# -> INT64 -> State# s -> State# s +writeInt64OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s writeInt64OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeInt64OffAddr#) a1 a2 a3 a4 {-# NOINLINE writeWord8OffAddr# #-} writeWord8OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s @@ -769,7 +689,7 @@ writeWord32OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s writeWord32OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWord32OffAddr#) a1 a2 a3 a4 {-# NOINLINE writeWord64OffAddr# #-} -writeWord64OffAddr# :: Addr# -> Int# -> WORD64 -> State# s -> State# s +writeWord64OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s writeWord64OffAddr# a1 a2 a3 a4 = (GHC.Prim.writeWord64OffAddr#) a1 a2 a3 a4 {-# NOINLINE newMutVar# #-} newMutVar# :: a -> State# s -> (# State# s,MutVar# s a #) @@ -825,6 +745,9 @@ {-# NOINLINE readTVar# #-} readTVar# :: TVar# s a -> State# s -> (# State# s,a #) readTVar# a1 a2 = (GHC.Prim.readTVar#) a1 a2 +{-# NOINLINE readTVarIO# #-} +readTVarIO# :: TVar# s a -> State# s -> (# State# s,a #) +readTVarIO# a1 a2 = (GHC.Prim.readTVarIO#) a1 a2 {-# NOINLINE writeTVar# #-} writeTVar# :: TVar# s a -> a -> State# s -> State# s writeTVar# a1 a2 a3 = (GHC.Prim.writeTVar#) a1 a2 a3 @@ -924,6 +847,9 @@ {-# NOINLINE reallyUnsafePtrEquality# #-} reallyUnsafePtrEquality# :: a -> a -> Int# reallyUnsafePtrEquality# a1 a2 = (GHC.Prim.reallyUnsafePtrEquality#) a1 a2 +{-# NOINLINE getSpark# #-} +getSpark# :: State# s -> (# State# s,Int#,a #) +getSpark# a1 = (GHC.Prim.getSpark#) a1 {-# NOINLINE dataToTag# #-} dataToTag# :: a -> Int# dataToTag# a1 = (GHC.Prim.dataToTag#) a1 @@ -942,3 +868,9 @@ {-# NOINLINE getApStackVal# #-} getApStackVal# :: a -> Int# -> (# Int#,b #) getApStackVal# a1 a2 = (GHC.Prim.getApStackVal#) a1 a2 +{-# NOINLINE traceCcs# #-} +traceCcs# :: a -> b -> b +traceCcs# a1 a2 = (GHC.Prim.traceCcs#) a1 a2 +{-# NOINLINE traceEvent# #-} +traceEvent# :: Addr# -> State# s -> State# s +traceEvent# a1 a2 = (GHC.Prim.traceEvent#) a1 a2 diff --git a/lib/ghc-prim/GHC/Types.hs b/lib/ghc-prim/GHC/Types.hs --- a/lib/ghc-prim/GHC/Types.hs +++ b/lib/ghc-prim/GHC/Types.hs @@ -1,7 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Types +-- Copyright : (c) The University of Glasgow 2009 +-- License : see libraries/ghc-prim/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- GHC type definitions. +-- Use GHC.Exts from the base package instead of importing this +-- module directly. +-- +----------------------------------------------------------------------------- {-# OPTIONS_GHC -XNoImplicitPrelude #-} -module GHC.Types (Char(..), Int(..), Float(..), Double(..)) where +module GHC.Types (Char(..), Int(..), Float(..), Double(..), IO(..)) where import GHC.Prim -- We need Inl etc behind the scenes for the type definitions @@ -27,4 +42,19 @@ -- It is desirable that this type be at least equal in range and precision -- to the IEEE double-precision type. data Double = D# Double# + +{-| +A value of type @'IO' a@ is a computation which, when performed, +does some I\/O before returning a value of type @a@. + +There is really only one way to \"perform\" an I\/O action: bind it to +@Main.main@ in your program. When your program is run, the I\/O will +be performed. It isn't possible to perform I\/O from an arbitrary +function, unless that function is itself in the 'IO' monad and called +at some point, directly or indirectly, from @Main.main@. + +'IO' is a monad, so 'IO' actions can be combined using either the do-notation +or the '>>' and '>>=' operations from the 'Monad' class. +-} +newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) diff --git a/lib/ghc-prim/Setup.hs b/lib/ghc-prim/Setup.hs --- a/lib/ghc-prim/Setup.hs +++ b/lib/ghc-prim/Setup.hs @@ -23,8 +23,6 @@ $ regHook simpleUserHooks, buildHook = build_primitive_sources $ buildHook simpleUserHooks, - makefileHook = build_primitive_sources - $ makefileHook simpleUserHooks, haddockHook = addPrimModuleForHaddock $ build_primitive_sources $ haddockHook simpleUserHooks } diff --git a/lib/ghc-prim/cbits/longlong.c b/lib/ghc-prim/cbits/longlong.c deleted file mode 100644 --- a/lib/ghc-prim/cbits/longlong.c +++ /dev/null @@ -1,129 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: longlong.c,v 1.4 2002/12/13 14:23:42 simonmar Exp $ - * - * (c) The GHC Team, 1998-1999 - * - * Primitive operations over (64-bit) long longs - * (only used on 32-bit platforms.) - * - * ---------------------------------------------------------------------------*/ - - -/* -Miscellaneous primitive operations on HsInt64 and HsWord64s. -N.B. These are not primops! - -Instead of going the normal (boring) route of making the list -of primitive operations even longer to cope with operations -over 64-bit entities, we implement them instead 'out-of-line'. - -The primitive ops get their own routine (in C) that implements -the operation, requiring the caller to _ccall_ out. This has -performance implications of course, but we currently don't -expect intensive use of either Int64 or Word64 types. - -The exceptions to the rule are primops that cast to and from -64-bit entities (these are defined in PrimOps.h) -*/ - -#include "Rts.h" - -#ifdef SUPPORT_LONG_LONGS - -/* Relational operators */ - -static inline HsBool mkBool(int b) { return b ? HS_BOOL_TRUE : HS_BOOL_FALSE; } - -HsBool hs_gtWord64 (HsWord64 a, HsWord64 b) {return mkBool(a > b);} -HsBool hs_geWord64 (HsWord64 a, HsWord64 b) {return mkBool(a >= b);} -HsBool hs_eqWord64 (HsWord64 a, HsWord64 b) {return mkBool(a == b);} -HsBool hs_neWord64 (HsWord64 a, HsWord64 b) {return mkBool(a != b);} -HsBool hs_ltWord64 (HsWord64 a, HsWord64 b) {return mkBool(a < b);} -HsBool hs_leWord64 (HsWord64 a, HsWord64 b) {return mkBool(a <= b);} - -HsBool hs_gtInt64 (HsInt64 a, HsInt64 b) {return mkBool(a > b);} -HsBool hs_geInt64 (HsInt64 a, HsInt64 b) {return mkBool(a >= b);} -HsBool hs_eqInt64 (HsInt64 a, HsInt64 b) {return mkBool(a == b);} -HsBool hs_neInt64 (HsInt64 a, HsInt64 b) {return mkBool(a != b);} -HsBool hs_ltInt64 (HsInt64 a, HsInt64 b) {return mkBool(a < b);} -HsBool hs_leInt64 (HsInt64 a, HsInt64 b) {return mkBool(a <= b);} - -/* Arithmetic operators */ - -HsWord64 hs_remWord64 (HsWord64 a, HsWord64 b) {return a % b;} -HsWord64 hs_quotWord64 (HsWord64 a, HsWord64 b) {return a / b;} - -HsInt64 hs_remInt64 (HsInt64 a, HsInt64 b) {return a % b;} -HsInt64 hs_quotInt64 (HsInt64 a, HsInt64 b) {return a / b;} -HsInt64 hs_negateInt64 (HsInt64 a) {return -a;} -HsInt64 hs_plusInt64 (HsInt64 a, HsInt64 b) {return a + b;} -HsInt64 hs_minusInt64 (HsInt64 a, HsInt64 b) {return a - b;} -HsInt64 hs_timesInt64 (HsInt64 a, HsInt64 b) {return a * b;} - -/* Logical operators: */ - -HsWord64 hs_and64 (HsWord64 a, HsWord64 b) {return a & b;} -HsWord64 hs_or64 (HsWord64 a, HsWord64 b) {return a | b;} -HsWord64 hs_xor64 (HsWord64 a, HsWord64 b) {return a ^ b;} -HsWord64 hs_not64 (HsWord64 a) {return ~a;} - -HsWord64 hs_uncheckedShiftL64 (HsWord64 a, HsInt b) {return a << b;} -HsWord64 hs_uncheckedShiftRL64 (HsWord64 a, HsInt b) {return a >> b;} -/* Right shifting of signed quantities is not portable in C, so - the behaviour you'll get from using these primops depends - on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98 -*/ -HsInt64 hs_uncheckedIShiftL64 (HsInt64 a, HsInt b) {return a << b;} -HsInt64 hs_uncheckedIShiftRA64 (HsInt64 a, HsInt b) {return a >> b;} -HsInt64 hs_uncheckedIShiftRL64 (HsInt64 a, HsInt b) - {return (HsInt64) ((HsWord64) a >> b);} - -/* Casting between longs and longer longs. - (the primops that cast from long longs to Integers - expressed as macros, since these may cause some heap allocation). -*/ - -HsInt64 hs_intToInt64 (HsInt i) {return (HsInt64) i;} -HsInt hs_int64ToInt (HsInt64 i) {return (HsInt) i;} -HsWord64 hs_int64ToWord64 (HsInt64 i) {return (HsWord64) i;} -HsWord64 hs_wordToWord64 (HsWord w) {return (HsWord64) w;} -HsWord hs_word64ToWord (HsWord64 w) {return (HsWord) w;} -HsInt64 hs_word64ToInt64 (HsWord64 w) {return (HsInt64) w;} - -HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da) -{ - mp_limb_t* d; - HsInt s; - HsWord64 res; - d = (mp_limb_t *)da; - s = sa; - switch (s) { - case 0: res = 0; break; - case 1: res = d[0]; break; - case -1: res = -(HsWord64)d[0]; break; - default: - res = (HsWord64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t))); - if (s < 0) res = -res; - } - return res; -} - -HsInt64 hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da) -{ - mp_limb_t* d; - HsInt s; - HsInt64 res; - d = (mp_limb_t *)da; - s = (sa); - switch (s) { - case 0: res = 0; break; - case 1: res = d[0]; break; - case -1: res = -(HsInt64)d[0]; break; - default: - res = (HsInt64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t))); - if (s < 0) res = -res; - } - return res; -} - -#endif /* SUPPORT_LONG_LONGS */ diff --git a/lib/ghc-prim/ghc-prim.cabal b/lib/ghc-prim/ghc-prim.cabal --- a/lib/ghc-prim/ghc-prim.cabal +++ b/lib/ghc-prim/ghc-prim.cabal @@ -1,20 +1,32 @@ name: ghc-prim -version: 0.1.0.0 +version: 0.2.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29 synopsis: GHC primitives description: GHC primitives. -cabal-version: >=1.2 +cabal-version: >=1.6 build-type: Custom +source-repository head + type: darcs + location: http://darcs.haskell.org/packages/ghc-prim/ + +flag include-ghc-prim { + Description: Include GHC.Prim in exposed-modules + default: False +} + Library { if impl(ghc) build-depends: rts exposed-modules: GHC.Bool + GHC.Debug GHC.Generics + GHC.Magic GHC.Ordering GHC.PrimopWrappers GHC.IntWord32 @@ -22,6 +34,11 @@ GHC.Tuple GHC.Types GHC.Unit + + if flag(include-ghc-prim) { + exposed-modules: GHC.Prim + } + extensions: CPP, MagicHash, ForeignFunctionInterface, UnliftedFFITypes, UnboxedTuples, EmptyDataDecls, NoImplicitPrelude -- We need to set the package name to ghc-prim (without a version number) diff --git a/lib/integer-ltm/LICENSE b/lib/integer-ltm/LICENSE new file mode 100644 --- /dev/null +++ b/lib/integer-ltm/LICENSE @@ -0,0 +1,83 @@ +This library (libraries/base) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- diff --git a/lib/integer-ltm/Setup.hs b/lib/integer-ltm/Setup.hs new file mode 100644 --- /dev/null +++ b/lib/integer-ltm/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/lib/integer-ltm/integer.cabal b/lib/integer-ltm/integer.cabal new file mode 100644 --- /dev/null +++ b/lib/integer-ltm/integer.cabal @@ -0,0 +1,22 @@ +name: integer-gmp +version: 0.1 +license: BSD3 +license-file: LICENSE +maintainer: lhc@haskell.org +synopsis: Integer library +cabal-version: >=1.2 +build-type: Simple + +Library { + extensions: CPP, NoImplicitPrelude + build-depends: ghc-prim + ghc-options: -fglasgow-exts + + Exposed-modules: + GHC.Integer + GHC.Integer.Ltm + GHC.Integer.Type + + Hs-source-dirs: src + ghc-options: -package-name integer-gmp +} diff --git a/lib/integer-ltm/src/GHC/Integer.hs b/lib/integer-ltm/src/GHC/Integer.hs new file mode 100644 --- /dev/null +++ b/lib/integer-ltm/src/GHC/Integer.hs @@ -0,0 +1,191 @@ +module GHC.Integer + ( Integer + , toInt# + , eqInteger + , neqInteger + , ltInteger + , leInteger + , gtInteger + , geInteger + , compareInteger + , quotRemInteger + , plusInteger + , minusInteger + , timesInteger + , negateInteger + , absInteger + , signumInteger + , smallInteger + , quotInteger + , remInteger + , divModInteger + , lcmInteger + , gcdInteger + , andInteger + , orInteger + , xorInteger + , complementInteger + +#if WORD_SIZE == 4 + , integerToWord64 + , integerToInt64 + , word64ToInteger + , int64ToInteger +#endif + + , wordToInteger + , integerToWord + , floatFromInteger + , doubleFromInteger + ) where + +import GHC.Types +import GHC.Prim +import GHC.Bool +import GHC.Ordering +import GHC.IntWord64 + +import GHC.Integer.Ltm +import GHC.Integer.Type + +toInt# :: Integer -> Int# +toInt# (Integer a) = mp_get_int a + +eqInteger :: Integer -> Integer -> Bool +eqInteger (Integer a) (Integer b) = mp_cmp a b ==# 0# + +neqInteger :: Integer -> Integer -> Bool +neqInteger (Integer a) (Integer b) = mp_cmp a b /=# 0# + +ltInteger :: Integer -> Integer -> Bool +ltInteger (Integer a) (Integer b) = mp_cmp a b ==# (-1#) + +leInteger :: Integer -> Integer -> Bool +leInteger (Integer a) (Integer b) = mp_cmp a b /=# 1# + +gtInteger :: Integer -> Integer -> Bool +gtInteger (Integer a) (Integer b) = mp_cmp a b ==# 1# + +geInteger :: Integer -> Integer -> Bool +geInteger (Integer a) (Integer b) = mp_cmp a b /=# (-1#) + +compareInteger :: Integer -> Integer -> Ordering +compareInteger (Integer a) (Integer b) + = case mp_cmp a b of + (-1#) -> LT + 0# -> EQ + 1# -> GT + +quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) +quotRemInteger a b = (# quotInteger a b, remInteger a b #) + +#define BIN_OP(fn) \(Integer a) (Integer b) -> Integer (fn a b) +#define UN_OP(fn) \(Integer a) -> Integer (fn a) + +plusInteger :: Integer -> Integer -> Integer +plusInteger = BIN_OP(mp_add) + +minusInteger :: Integer -> Integer -> Integer +minusInteger = BIN_OP(mp_sub) + +timesInteger :: Integer -> Integer -> Integer +timesInteger = BIN_OP(mp_mul) + +negateInteger :: Integer -> Integer +negateInteger = UN_OP(mp_negate) + +absInteger :: Integer -> Integer +absInteger = UN_OP(mp_abs) + +signumInteger :: Integer -> Integer +signumInteger i = case compareInteger i (smallInteger 0#) of + LT -> smallInteger (-1#) + EQ -> smallInteger (0#) + GT -> smallInteger (1#) + +smallInteger :: Int# -> Integer +smallInteger val = Integer (mp_from_int val) + +quotInteger :: Integer -> Integer -> Integer +quotInteger = BIN_OP(mp_quot) + +remInteger :: Integer -> Integer -> Integer +remInteger = BIN_OP(mp_rem) + +divModInteger :: Integer -> Integer -> (# Integer, Integer #) +divModInteger a b = (# divInteger a b, modInteger a b #) + +lcmInteger :: Integer -> Integer -> Integer +lcmInteger = BIN_OP(mp_lcm) + +gcdInteger :: Integer -> Integer -> Integer +gcdInteger = BIN_OP(mp_gcd) + +andInteger :: Integer -> Integer -> Integer +andInteger = BIN_OP(mp_and) + +orInteger :: Integer -> Integer -> Integer +orInteger = BIN_OP(mp_or) + +xorInteger :: Integer -> Integer -> Integer +xorInteger = BIN_OP(mp_xor) + +complementInteger :: Integer -> Integer +complementInteger i = negateInteger i `minusInteger` smallInteger 1# + + +#if WORD_SIZE == 4 +integerToWord64 :: Integer -> Word64# +integerToWord64 = integerToWord64 + +integerToInt64 :: Integer -> Int64# +integerToInt64 = integerToInt64 + +word64ToInteger :: Word64# -> Integer +word64ToInteger = word64ToInteger + +int64ToInteger :: Int64# -> Integer +int64ToInteger = int64ToInteger +#endif + + +wordToInteger :: Word# -> Integer +wordToInteger w = smallInteger (word2Int# w) + +integerToWord :: Integer -> Word# +integerToWord i = int2Word# (toInt# i) + +floatFromInteger :: Integer -> Float# +floatFromInteger i = int2Float# (toInt# i) + +doubleFromInteger :: Integer -> Double# +doubleFromInteger i = int2Double# (toInt# i) + +divInteger :: Integer -> Integer -> Integer +x `divInteger` y + -- Be careful NOT to overflow if we do any additional arithmetic + -- on the arguments... the following previous version of this + -- code has problems with overflow: +-- | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y# +-- | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y# + = if (x `gtInteger` smallInteger 0#) && (y `ltInteger` smallInteger 0#) + then ((x `minusInteger` smallInteger 1#) `quotInteger` y) `minusInteger` smallInteger 1# + else if (x `ltInteger` smallInteger 0#) && (y `gtInteger` smallInteger 0#) + then ((x `plusInteger` smallInteger 1#) `quotInteger` y) `minusInteger` smallInteger 1# + else x `quotInteger` y + +modInteger :: Integer -> Integer -> Integer +x `modInteger` y + = if (x `gtInteger` smallInteger 0#) && (y `ltInteger` smallInteger 0#) || + (x `ltInteger` smallInteger 0#) && (y `gtInteger` smallInteger 0#) + then if r `neqInteger` smallInteger 0# then r `plusInteger` y else smallInteger 0# + else r + where + r = x `remInteger` y + +True && True = True +_ && _ = False +otherwise = True +False || False = False +_ || _ = True + diff --git a/lib/integer-ltm/src/GHC/Integer/Ltm.hs b/lib/integer-ltm/src/GHC/Integer/Ltm.hs new file mode 100644 --- /dev/null +++ b/lib/integer-ltm/src/GHC/Integer/Ltm.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, UnliftedFFITypes #-} +module GHC.Integer.Ltm where + +import GHC.Types +import GHC.Prim + +type Mp_int = Addr# + +foreign import ccall unsafe "lhc_mp_cmp" mp_cmp :: Mp_int -> Mp_int -> Int# +foreign import ccall unsafe "lhc_mp_get_int" mp_get_int :: Mp_int -> Int# + +foreign import ccall unsafe "lhc_mp_from_int" mp_from_int :: Int# -> Mp_int +foreign import ccall unsafe "lhc_mp_mul" mp_mul :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_add" mp_add :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_sub" mp_sub :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_or" mp_or :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_and" mp_and :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_xor" mp_xor :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_gcd" mp_gcd :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_lcm" mp_lcm :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_quot" mp_quot :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_rem" mp_rem :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_abs" mp_abs :: Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_negate" mp_negate :: Mp_int -> Mp_int + diff --git a/lib/integer-ltm/src/GHC/Integer/Type.hs b/lib/integer-ltm/src/GHC/Integer/Type.hs new file mode 100644 --- /dev/null +++ b/lib/integer-ltm/src/GHC/Integer/Type.hs @@ -0,0 +1,6 @@ +module GHC.Integer.Type where + + +import GHC.Integer.Ltm + +data Integer = Integer Mp_int diff --git a/lib/integer-native/LICENSE b/lib/integer-native/LICENSE deleted file mode 100644 --- a/lib/integer-native/LICENSE +++ /dev/null @@ -1,83 +0,0 @@ -This library (libraries/base) is derived from code from several -sources: - - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - - * Code from the Haskell Foreign Function Interface specification, - which is (c) Manuel M. T. Chakravarty and freely redistributable - (but see the full license for restrictions). - -The full text of these licenses is reproduced below. All of the -licenses are BSD-style or compatible. - ------------------------------------------------------------------------------ - -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - ------------------------------------------------------------------------------ - -Code derived from the document "Report on the Programming Language -Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - ------------------------------------------------------------------------------ - -Code derived from the document "The Haskell 98 Foreign Function -Interface, An Addendum to the Haskell 98 Report" is distributed under -the following license: - - Copyright (c) 2002 Manuel M. T. Chakravarty - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Foreign Function Interface. - ------------------------------------------------------------------------------ diff --git a/lib/integer-native/Setup.lhs b/lib/integer-native/Setup.lhs deleted file mode 100644 --- a/lib/integer-native/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/lib/integer-native/integer.cabal b/lib/integer-native/integer.cabal deleted file mode 100644 --- a/lib/integer-native/integer.cabal +++ /dev/null @@ -1,22 +0,0 @@ -name: integer -version: 0.1 -license: BSD3 -license-file: LICENSE -maintainer: lhc@haskell.org -synopsis: Integer library -cabal-version: >=1.2 -build-type: Simple - -Library { - extensions: CPP, NoImplicitPrelude - build-depends: ghc-prim - ghc-options: -fglasgow-exts - - - Exposed-modules: - GHC.Integer - GHC.Integer.Internals - - Hs-source-dirs: src - ghc-options: -package-name integer -} diff --git a/lib/integer-native/src/GHC/Integer.hs b/lib/integer-native/src/GHC/Integer.hs deleted file mode 100644 --- a/lib/integer-native/src/GHC/Integer.hs +++ /dev/null @@ -1,193 +0,0 @@ -module GHC.Integer - ( Integer - , toInt# - , eqInteger - , neqInteger - , ltInteger - , leInteger - , gtInteger - , geInteger - , compareInteger - , quotRemInteger - , plusInteger - , minusInteger - , timesInteger - , negateInteger - , absInteger - , signumInteger - , smallInteger - , quotInteger - , remInteger - , divModInteger - , lcmInteger - , gcdInteger - , andInteger - , orInteger - , xorInteger - , complementInteger -#if WORD_SIZE == 4 - , integerToWord64 - , integerToInt64 - , word64ToInteger - , int64ToInteger -#endif - , wordToInteger - , integerToWord - , floatFromInteger - , doubleFromInteger - ) where - -import GHC.Types -import GHC.Prim -import GHC.Bool -import GHC.Ordering -import GHC.IntWord64 -import GHC.Integer.Internals - -toInt# :: Integer -> Int# -toInt# (Integer i) = i - -eqInteger :: Integer -> Integer -> Bool -eqInteger (Integer a) (Integer b) = a ==# b - -neqInteger :: Integer -> Integer -> Bool -neqInteger (Integer a) (Integer b) = a /=# b - -ltInteger :: Integer -> Integer -> Bool -ltInteger (Integer a) (Integer b) = a <# b - -leInteger :: Integer -> Integer -> Bool -leInteger (Integer a) (Integer b) = a <=# b - -gtInteger :: Integer -> Integer -> Bool -gtInteger (Integer a) (Integer b) = a ># b - -geInteger :: Integer -> Integer -> Bool -geInteger (Integer a) (Integer b) = a >=# b - -compareInteger :: Integer -> Integer -> Ordering -compareInteger (Integer a) (Integer b) - = if a ># b - then GT - else if a ==# b - then EQ - else LT - -quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) -quotRemInteger (Integer a) (Integer b) - = (# Integer (a `quotInt#` b), Integer (a `remInt#` b) #) - -plusInteger :: Integer -> Integer -> Integer -plusInteger (Integer a) (Integer b) = Integer (a +# b) - -minusInteger :: Integer -> Integer -> Integer -minusInteger (Integer a) (Integer b) = Integer (a -# b) - -timesInteger :: Integer -> Integer -> Integer -timesInteger (Integer a) (Integer b) = Integer (a *# b) - -negateInteger :: Integer -> Integer -negateInteger (Integer a) = Integer (negateInt# a) - -absInteger :: Integer -> Integer -absInteger (Integer n) = Integer (if n ># 0# then n else negateInt# n) - -signumInteger :: Integer -> Integer -signumInteger (Integer i) - = if i <# 0# - then Integer (negateInt# 1#) else if i ==# 0# - then Integer 0# - else Integer 1# - -smallInteger :: Int# -> Integer -smallInteger i - = Integer i - -quotInteger :: Integer -> Integer -> Integer -quotInteger (Integer a) (Integer b) - = Integer (a `quotInt#` b) - -remInteger :: Integer -> Integer -> Integer -remInteger (Integer a) (Integer b) - = Integer (a `remInt#` b) - -divModInteger :: Integer -> Integer -> (# Integer, Integer #) -divModInteger (Integer a) (Integer b) - = (# Integer (a `divInt#` b), Integer (a `modInt#` b) #) - -lcmInteger :: Integer -> Integer -> Integer -lcmInteger a b = a - -gcdInteger :: Integer -> Integer -> Integer -gcdInteger (Integer a) (Integer b) = Integer (a `gcdInt#` b) - -andInteger :: Integer -> Integer -> Integer -andInteger (Integer a) (Integer b) - = Integer (word2Int# (int2Word# a `and#` int2Word# b)) - -orInteger :: Integer -> Integer -> Integer -orInteger (Integer a) (Integer b) - = Integer (word2Int# (int2Word# a `or#` int2Word# b)) - -xorInteger :: Integer -> Integer -> Integer -xorInteger (Integer a) (Integer b) - = Integer (word2Int# (int2Word# a `xor#` int2Word# b)) - -complementInteger :: Integer -> Integer -complementInteger (Integer x#) - = Integer (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) - -#if WORD_SIZE == 4 -integerToWord64 :: Integer -> Word64# -integerToWord64 (Integer x) = int64ToWord64# (intToInt64# x) - -integerToInt64 :: Integer -> Int64# -integerToInt64 (Integer x) = intToInt64# x - -word64ToInteger :: Word64# -> Integer -word64ToInteger w = Integer (int64ToInt# (word64ToInt64# w)) - -int64ToInteger :: Int64# -> Integer -int64ToInteger i = smallInteger (int64ToInt# i) -#endif - -wordToInteger :: Word# -> Integer -wordToInteger w = Integer (word2Int# w) - -integerToWord :: Integer -> Word# -integerToWord (Integer i) = int2Word# i - -floatFromInteger :: Integer -> Float# -floatFromInteger (Integer i) = int2Float# i - -doubleFromInteger :: Integer -> Double# -doubleFromInteger (Integer i) = int2Double# i - -divInt# :: Int# -> Int# -> Int# -x# `divInt#` y# - -- Be careful NOT to overflow if we do any additional arithmetic - -- on the arguments... the following previous version of this - -- code has problems with overflow: --- | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y# --- | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y# - = if (x# ># 0#) && (y# <# 0#) - then ((x# -# 1#) `quotInt#` y#) -# 1# - else if (x# <# 0#) && (y# ># 0#) - then ((x# +# 1#) `quotInt#` y#) -# 1# - else x# `quotInt#` y# - -modInt# :: Int# -> Int# -> Int# -x# `modInt#` y# - = if (x# ># 0#) && (y# <# 0#) || - (x# <# 0#) && (y# ># 0#) - then if r# /=# 0# then r# +# y# else 0# - else r# - where - r# = x# `remInt#` y# - -True && True = True -_ && _ = False -otherwise = True -False || False = False -_ || _ = True - diff --git a/lib/integer-native/src/GHC/Integer/Internals.hs b/lib/integer-native/src/GHC/Integer/Internals.hs deleted file mode 100644 --- a/lib/integer-native/src/GHC/Integer/Internals.hs +++ /dev/null @@ -1,7 +0,0 @@ -module GHC.Integer.Internals where - -import GHC.Prim -import GHC.Types - -data Integer = Integer Int# - diff --git a/rts/ltm/bn_error.c b/rts/ltm/bn_error.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_error.c @@ -0,0 +1,47 @@ +#include +#ifdef BN_ERROR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +static const struct { + int code; + char *msg; +} msgs[] = { + { MP_OKAY, "Successful" }, + { MP_MEM, "Out of heap" }, + { MP_VAL, "Value out of range" } +}; + +/* return a char * string for a given code */ +char *mp_error_to_string(int code) +{ + int x; + + /* scan the lookup table for the given message */ + for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) { + if (msgs[x].code == code) { + return msgs[x].msg; + } + } + + /* generic reply for invalid code */ + return "Invalid error code"; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_error.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_fast_mp_invmod.c b/rts/ltm/bn_fast_mp_invmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_fast_mp_invmod.c @@ -0,0 +1,148 @@ +#include +#ifdef BN_FAST_MP_INVMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes the modular inverse via binary extended euclidean algorithm, + * that is c = 1/a mod b + * + * Based on slow invmod except this is optimized for the case where b is + * odd as per HAC Note 14.64 on pp. 610 + */ +int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x, y, u, v, B, D; + int res, neg; + + /* 2. [modified] b must be odd */ + if (mp_iseven (b) == 1) { + return MP_VAL; + } + + /* init all our temps */ + if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { + return res; + } + + /* x == modulus, y == value to invert */ + if ((res = mp_copy (b, &x)) != MP_OKAY) { + goto LBL_ERR; + } + + /* we need y = |a| */ + if ((res = mp_mod (a, b, &y)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((res = mp_copy (&x, &u)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (&y, &v)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set (&D, 1); + +top: + /* 4. while u is even do */ + while (mp_iseven (&u) == 1) { + /* 4.1 u = u/2 */ + if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { + goto LBL_ERR; + } + /* 4.2 if B is odd then */ + if (mp_isodd (&B) == 1) { + if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* B = B/2 */ + if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 5. while v is even do */ + while (mp_iseven (&v) == 1) { + /* 5.1 v = v/2 */ + if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { + goto LBL_ERR; + } + /* 5.2 if D is odd then */ + if (mp_isodd (&D) == 1) { + /* D = (D-x)/2 */ + if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* D = D/2 */ + if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 6. if u >= v then */ + if (mp_cmp (&u, &v) != MP_LT) { + /* u = u - v, B = B - D */ + if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } else { + /* v - v - u, D = D - B */ + if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* if not zero goto step 4 */ + if (mp_iszero (&u) == 0) { + goto top; + } + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d (&v, 1) != MP_EQ) { + res = MP_VAL; + goto LBL_ERR; + } + + /* b is now the inverse */ + neg = a->sign; + while (D.sign == MP_NEG) { + if ((res = mp_add (&D, b, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + mp_exch (&D, c); + c->sign = neg; + res = MP_OKAY; + +LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_fast_mp_invmod.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_fast_mp_montgomery_reduce.c b/rts/ltm/bn_fast_mp_montgomery_reduce.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_fast_mp_montgomery_reduce.c @@ -0,0 +1,172 @@ +#include +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes xR**-1 == x (mod N) via Montgomery Reduction + * + * This is an optimized implementation of montgomery_reduce + * which uses the comba method to quickly calculate the columns of the + * reduction. + * + * Based on Algorithm 14.32 on pp.601 of HAC. +*/ +int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +{ + int ix, res, olduse; + mp_word W[MP_WARRAY]; + + /* get old used count */ + olduse = x->used; + + /* grow a as required */ + if (x->alloc < n->used + 1) { + if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) { + return res; + } + } + + /* first we have to get the digits of the input into + * an array of double precision words W[...] + */ + { + register mp_word *_W; + register mp_digit *tmpx; + + /* alias for the W[] array */ + _W = W; + + /* alias for the digits of x*/ + tmpx = x->dp; + + /* copy the digits of a into W[0..a->used-1] */ + for (ix = 0; ix < x->used; ix++) { + *_W++ = *tmpx++; + } + + /* zero the high words of W[a->used..m->used*2] */ + for (; ix < n->used * 2 + 1; ix++) { + *_W++ = 0; + } + } + + /* now we proceed to zero successive digits + * from the least significant upwards + */ + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * m' mod b + * + * We avoid a double precision multiplication (which isn't required) + * by casting the value down to a mp_digit. Note this requires + * that W[ix-1] have the carry cleared (see after the inner loop) + */ + register mp_digit mu; + mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK); + + /* a = a + mu * m * b**i + * + * This is computed in place and on the fly. The multiplication + * by b**i is handled by offseting which columns the results + * are added to. + * + * Note the comba method normally doesn't handle carries in the + * inner loop In this case we fix the carry from the previous + * column since the Montgomery reduction requires digits of the + * result (so far) [see above] to work. This is + * handled by fixing up one carry after the inner loop. The + * carry fixups are done in order so after these loops the + * first m->used words of W[] have the carries fixed + */ + { + register int iy; + register mp_digit *tmpn; + register mp_word *_W; + + /* alias for the digits of the modulus */ + tmpn = n->dp; + + /* Alias for the columns set by an offset of ix */ + _W = W + ix; + + /* inner loop */ + for (iy = 0; iy < n->used; iy++) { + *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++); + } + } + + /* now fix carry for next digit, W[ix+1] */ + W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT); + } + + /* now we have to propagate the carries and + * shift the words downward [all those least + * significant digits we zeroed]. + */ + { + register mp_digit *tmpx; + register mp_word *_W, *_W1; + + /* nox fix rest of carries */ + + /* alias for current word */ + _W1 = W + ix; + + /* alias for next word, where the carry goes */ + _W = W + ++ix; + + for (; ix <= n->used * 2 + 1; ix++) { + *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT); + } + + /* copy out, A = A/b**n + * + * The result is A/b**n but instead of converting from an + * array of mp_word to mp_digit than calling mp_rshd + * we just copy them in the right order + */ + + /* alias for destination word */ + tmpx = x->dp; + + /* alias for shifted double precision result */ + _W = W + n->used; + + for (ix = 0; ix < n->used + 1; ix++) { + *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK)); + } + + /* zero oldused digits, if the input a was larger than + * m->used+1 we'll have to clear the digits + */ + for (; ix < olduse; ix++) { + *tmpx++ = 0; + } + } + + /* set the max used and clamp */ + x->used = n->used + 1; + mp_clamp (x); + + /* if A >= m then A = A - m */ + if (mp_cmp_mag (x, n) != MP_LT) { + return s_mp_sub (x, n, x); + } + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_fast_s_mp_mul_digs.c b/rts/ltm/bn_fast_s_mp_mul_digs.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_fast_s_mp_mul_digs.c @@ -0,0 +1,107 @@ +#include +#ifdef BN_FAST_S_MP_MUL_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Fast (comba) multiplier + * + * This is the fast column-array [comba] multiplier. It is + * designed to compute the columns of the product first + * then handle the carries afterwards. This has the effect + * of making the nested loops that compute the columns very + * simple and schedulable on super-scalar processors. + * + * This has been modified to produce a variable number of + * digits of output so if say only a half-product is required + * you don't have to compute the upper half (a feature + * required for fast Barrett reduction). + * + * Based on Algorithm 14.12 on pp.595 of HAC. + * + */ +int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY]; + register mp_word _W; + + /* grow the destination as required */ + if (c->alloc < digs) { + if ((res = mp_grow (c, digs)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + pa = MIN(digs, a->used + b->used); + + /* clear the carry */ + _W = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty; + int iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; ++iz) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + + } + + /* store term */ + W[ix] = ((mp_digit)_W) & MP_MASK; + + /* make next carry */ + _W = _W >> ((mp_word)DIGIT_BIT); + } + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + register mp_digit *tmpc; + tmpc = c->dp; + for (ix = 0; ix < pa+1; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpc++ = 0; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.7 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_fast_s_mp_mul_high_digs.c b/rts/ltm/bn_fast_s_mp_mul_high_digs.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_fast_s_mp_mul_high_digs.c @@ -0,0 +1,98 @@ +#include +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* this is a modified version of fast_s_mul_digs that only produces + * output digits *above* digs. See the comments for fast_s_mul_digs + * to see how it works. + * + * This is used in the Barrett reduction since for one of the multiplications + * only the higher digits were needed. This essentially halves the work. + * + * Based on Algorithm 14.12 on pp.595 of HAC. + */ +int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY]; + mp_word _W; + + /* grow the destination as required */ + pa = a->used + b->used; + if (c->alloc < pa) { + if ((res = mp_grow (c, pa)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + pa = a->used + b->used; + _W = 0; + for (ix = digs; ix < pa; ix++) { + int tx, ty, iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially its + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + } + + /* store term */ + W[ix] = ((mp_digit)_W) & MP_MASK; + + /* make next carry */ + _W = _W >> ((mp_word)DIGIT_BIT); + } + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + register mp_digit *tmpc; + + tmpc = c->dp + digs; + for (ix = digs; ix <= pa; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpc++ = 0; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_fast_s_mp_sqr.c b/rts/ltm/bn_fast_s_mp_sqr.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_fast_s_mp_sqr.c @@ -0,0 +1,114 @@ +#include +#ifdef BN_FAST_S_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* the jist of squaring... + * you do like mult except the offset of the tmpx [one that + * starts closer to zero] can't equal the offset of tmpy. + * So basically you set up iy like before then you min it with + * (ty-tx) so that it never happens. You double all those + * you add in the inner loop + +After that loop you do the squares and add them in. +*/ + +int fast_s_mp_sqr (mp_int * a, mp_int * b) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY], *tmpx; + mp_word W1; + + /* grow the destination as required */ + pa = a->used + a->used; + if (b->alloc < pa) { + if ((res = mp_grow (b, pa)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + W1 = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty, iy; + mp_word _W; + mp_digit *tmpy; + + /* clear counter */ + _W = 0; + + /* get offsets into the two bignums */ + ty = MIN(a->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = a->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* now for squaring tx can never equal ty + * we halve the distance since they approach at a rate of 2x + * and we have to round because odd cases need to be executed + */ + iy = MIN(iy, (ty-tx+1)>>1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + } + + /* double the inner product and add carry */ + _W = _W + _W + W1; + + /* even columns have the square term in them */ + if ((ix&1) == 0) { + _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]); + } + + /* store it */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* make next carry */ + W1 = _W >> ((mp_word)DIGIT_BIT); + } + + /* setup dest */ + olduse = b->used; + b->used = a->used+a->used; + + { + mp_digit *tmpb; + tmpb = b->dp; + for (ix = 0; ix < pa; ix++) { + *tmpb++ = W[ix] & MP_MASK; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpb++ = 0; + } + } + mp_clamp (b); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_fast_s_mp_sqr.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_2expt.c b/rts/ltm/bn_mp_2expt.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_2expt.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_2EXPT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes a = 2**b + * + * Simple algorithm which zeroes the int, grows it then just sets one bit + * as required. + */ +int +mp_2expt (mp_int * a, int b) +{ + int res; + + /* zero a as per default */ + mp_zero (a); + + /* grow a to accomodate the single bit */ + if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) { + return res; + } + + /* set the used count of where the bit will go */ + a->used = b / DIGIT_BIT + 1; + + /* put the single bit in its place */ + a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT); + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_2expt.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_abs.c b/rts/ltm/bn_mp_abs.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_abs.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_ABS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* b = |a| + * + * Simple function copies the input and fixes the sign to positive + */ +int +mp_abs (mp_int * a, mp_int * b) +{ + int res; + + /* copy a to b */ + if (a != b) { + if ((res = mp_copy (a, b)) != MP_OKAY) { + return res; + } + } + + /* force the sign of b to positive */ + b->sign = MP_ZPOS; + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_abs.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_add.c b/rts/ltm/bn_mp_add.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_add.c @@ -0,0 +1,53 @@ +#include +#ifdef BN_MP_ADD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* high level addition (handles signs) */ +int mp_add (mp_int * a, mp_int * b, mp_int * c) +{ + int sa, sb, res; + + /* get sign of both inputs */ + sa = a->sign; + sb = b->sign; + + /* handle two cases, not four */ + if (sa == sb) { + /* both positive or both negative */ + /* add their magnitudes, copy the sign */ + c->sign = sa; + res = s_mp_add (a, b, c); + } else { + /* one positive, the other negative */ + /* subtract the one with the greater magnitude from */ + /* the one of the lesser magnitude. The result gets */ + /* the sign of the one with the greater magnitude. */ + if (mp_cmp_mag (a, b) == MP_LT) { + c->sign = sb; + res = s_mp_sub (b, a, c); + } else { + c->sign = sa; + res = s_mp_sub (a, b, c); + } + } + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_add.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_add_d.c b/rts/ltm/bn_mp_add_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_add_d.c @@ -0,0 +1,112 @@ +#include +#ifdef BN_MP_ADD_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* single digit addition */ +int +mp_add_d (mp_int * a, mp_digit b, mp_int * c) +{ + int res, ix, oldused; + mp_digit *tmpa, *tmpc, mu; + + /* grow c as required */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* if a is negative and |a| >= b, call c = |a| - b */ + if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) { + /* temporarily fix sign of a */ + a->sign = MP_ZPOS; + + /* c = |a| - b */ + res = mp_sub_d(a, b, c); + + /* fix sign */ + a->sign = c->sign = MP_NEG; + + /* clamp */ + mp_clamp(c); + + return res; + } + + /* old number of used digits in c */ + oldused = c->used; + + /* sign always positive */ + c->sign = MP_ZPOS; + + /* source alias */ + tmpa = a->dp; + + /* destination alias */ + tmpc = c->dp; + + /* if a is positive */ + if (a->sign == MP_ZPOS) { + /* add digit, after this we're propagating + * the carry. + */ + *tmpc = *tmpa++ + b; + mu = *tmpc >> DIGIT_BIT; + *tmpc++ &= MP_MASK; + + /* now handle rest of the digits */ + for (ix = 1; ix < a->used; ix++) { + *tmpc = *tmpa++ + mu; + mu = *tmpc >> DIGIT_BIT; + *tmpc++ &= MP_MASK; + } + /* set final carry */ + ix++; + *tmpc++ = mu; + + /* setup size */ + c->used = a->used + 1; + } else { + /* a was negative and |a| < b */ + c->used = 1; + + /* the result is a single digit */ + if (a->used == 1) { + *tmpc++ = b - a->dp[0]; + } else { + *tmpc++ = b; + } + + /* setup count so the clearing of oldused + * can fall through correctly + */ + ix = 1; + } + + /* now zero to oldused */ + while (ix++ < oldused) { + *tmpc++ = 0; + } + mp_clamp(c); + + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_add_d.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_addmod.c b/rts/ltm/bn_mp_addmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_addmod.c @@ -0,0 +1,41 @@ +#include +#ifdef BN_MP_ADDMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* d = a + b (mod c) */ +int +mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_add (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_addmod.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_and.c b/rts/ltm/bn_mp_and.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_and.c @@ -0,0 +1,57 @@ +#include +#ifdef BN_MP_AND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* AND two ints together */ +int +mp_and (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] &= x->dp[ix]; + } + + /* zero digits above the last from the smallest mp_int */ + for (; ix < t.used; ix++) { + t.dp[ix] = 0; + } + + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_and.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_clamp.c b/rts/ltm/bn_mp_clamp.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_clamp.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_CLAMP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* trim unused digits + * + * This is used to ensure that leading zero digits are + * trimed and the leading "used" digit will be non-zero + * Typically very fast. Also fixes the sign if there + * are no more leading digits + */ +void +mp_clamp (mp_int * a) +{ + /* decrease used while the most significant digit is + * zero. + */ + while (a->used > 0 && a->dp[a->used - 1] == 0) { + --(a->used); + } + + /* reset the sign flag if used == 0 */ + if (a->used == 0) { + a->sign = MP_ZPOS; + } +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_clamp.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_clear.c b/rts/ltm/bn_mp_clear.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_clear.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_CLEAR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* clear one (frees) */ +void +mp_clear (mp_int * a) +{ + int i; + + /* only do anything if a hasn't been freed previously */ + if (a->dp != NULL) { + /* first zero the digits */ + for (i = 0; i < a->used; i++) { + a->dp[i] = 0; + } + + /* free ram */ + XFREE(a->dp); + + /* reset members to make debugging easier */ + a->dp = NULL; + a->alloc = a->used = 0; + a->sign = MP_ZPOS; + } +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_clear.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_clear_multi.c b/rts/ltm/bn_mp_clear_multi.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_clear_multi.c @@ -0,0 +1,34 @@ +#include +#ifdef BN_MP_CLEAR_MULTI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ +#include + +void mp_clear_multi(mp_int *mp, ...) +{ + mp_int* next_mp = mp; + va_list args; + va_start(args, mp); + while (next_mp != NULL) { + mp_clear(next_mp); + next_mp = va_arg(args, mp_int*); + } + va_end(args); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_clear_multi.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_cmp.c b/rts/ltm/bn_mp_cmp.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_cmp.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_CMP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* compare two ints (signed)*/ +int +mp_cmp (mp_int * a, mp_int * b) +{ + /* compare based on sign */ + if (a->sign != b->sign) { + if (a->sign == MP_NEG) { + return MP_LT; + } else { + return MP_GT; + } + } + + /* compare digits */ + if (a->sign == MP_NEG) { + /* if negative compare opposite direction */ + return mp_cmp_mag(b, a); + } else { + return mp_cmp_mag(a, b); + } +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_cmp.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_cmp_d.c b/rts/ltm/bn_mp_cmp_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_cmp_d.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_CMP_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* compare a digit */ +int mp_cmp_d(mp_int * a, mp_digit b) +{ + /* compare based on sign */ + if (a->sign == MP_NEG) { + return MP_LT; + } + + /* compare based on magnitude */ + if (a->used > 1) { + return MP_GT; + } + + /* compare the only digit of a to b */ + if (a->dp[0] > b) { + return MP_GT; + } else if (a->dp[0] < b) { + return MP_LT; + } else { + return MP_EQ; + } +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_cmp_mag.c b/rts/ltm/bn_mp_cmp_mag.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_cmp_mag.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_CMP_MAG_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* compare maginitude of two ints (unsigned) */ +int mp_cmp_mag (mp_int * a, mp_int * b) +{ + int n; + mp_digit *tmpa, *tmpb; + + /* compare based on # of non-zero digits */ + if (a->used > b->used) { + return MP_GT; + } + + if (a->used < b->used) { + return MP_LT; + } + + /* alias for a */ + tmpa = a->dp + (a->used - 1); + + /* alias for b */ + tmpb = b->dp + (a->used - 1); + + /* compare based on digits */ + for (n = 0; n < a->used; ++n, --tmpa, --tmpb) { + if (*tmpa > *tmpb) { + return MP_GT; + } + + if (*tmpa < *tmpb) { + return MP_LT; + } + } + return MP_EQ; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_cmp_mag.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_cnt_lsb.c b/rts/ltm/bn_mp_cnt_lsb.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_cnt_lsb.c @@ -0,0 +1,53 @@ +#include +#ifdef BN_MP_CNT_LSB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +static const int lnz[16] = { + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 +}; + +/* Counts the number of lsbs which are zero before the first zero bit */ +int mp_cnt_lsb(mp_int *a) +{ + int x; + mp_digit q, qq; + + /* easy out */ + if (mp_iszero(a) == 1) { + return 0; + } + + /* scan lower digits until non-zero */ + for (x = 0; x < a->used && a->dp[x] == 0; x++); + q = a->dp[x]; + x *= DIGIT_BIT; + + /* now scan this digit until a 1 is found */ + if ((q & 1) == 0) { + do { + qq = q & 15; + x += lnz[qq]; + q >>= 4; + } while (qq == 0); + } + return x; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_cnt_lsb.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_copy.c b/rts/ltm/bn_mp_copy.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_copy.c @@ -0,0 +1,68 @@ +#include +#ifdef BN_MP_COPY_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* copy, b = a */ +int +mp_copy (mp_int * a, mp_int * b) +{ + int res, n; + + /* if dst == src do nothing */ + if (a == b) { + return MP_OKAY; + } + + /* grow dest */ + if (b->alloc < a->used) { + if ((res = mp_grow (b, a->used)) != MP_OKAY) { + return res; + } + } + + /* zero b and copy the parameters over */ + { + register mp_digit *tmpa, *tmpb; + + /* pointer aliases */ + + /* source */ + tmpa = a->dp; + + /* destination */ + tmpb = b->dp; + + /* copy all the digits */ + for (n = 0; n < a->used; n++) { + *tmpb++ = *tmpa++; + } + + /* clear high digits */ + for (; n < b->used; n++) { + *tmpb++ = 0; + } + } + + /* copy used count and sign */ + b->used = a->used; + b->sign = a->sign; + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_copy.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_count_bits.c b/rts/ltm/bn_mp_count_bits.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_count_bits.c @@ -0,0 +1,45 @@ +#include +#ifdef BN_MP_COUNT_BITS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* returns the number of bits in an int */ +int +mp_count_bits (mp_int * a) +{ + int r; + mp_digit q; + + /* shortcut */ + if (a->used == 0) { + return 0; + } + + /* get number of digits and add that */ + r = (a->used - 1) * DIGIT_BIT; + + /* take the last digit and count the bits in it */ + q = a->dp[a->used - 1]; + while (q > ((mp_digit) 0)) { + ++r; + q >>= ((mp_digit) 1); + } + return r; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_count_bits.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_div.c b/rts/ltm/bn_mp_div.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_div.c @@ -0,0 +1,292 @@ +#include +#ifdef BN_MP_DIV_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +#ifdef BN_MP_DIV_SMALL + +/* slower bit-bang division... also smaller */ +int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + mp_int ta, tb, tq, q; + int res, n, n2; + + /* is divisor zero ? */ + if (mp_iszero (b) == 1) { + return MP_VAL; + } + + /* if a < b then q=0, r = a */ + if (mp_cmp_mag (a, b) == MP_LT) { + if (d != NULL) { + res = mp_copy (a, d); + } else { + res = MP_OKAY; + } + if (c != NULL) { + mp_zero (c); + } + return res; + } + + /* init our temps */ + if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) { + return res; + } + + + mp_set(&tq, 1); + n = mp_count_bits(a) - mp_count_bits(b); + if (((res = mp_abs(a, &ta)) != MP_OKAY) || + ((res = mp_abs(b, &tb)) != MP_OKAY) || + ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || + ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { + goto LBL_ERR; + } + + while (n-- >= 0) { + if (mp_cmp(&tb, &ta) != MP_GT) { + if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || + ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) { + goto LBL_ERR; + } + } + if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || + ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) { + goto LBL_ERR; + } + } + + /* now q == quotient and ta == remainder */ + n = a->sign; + n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG); + if (c != NULL) { + mp_exch(c, &q); + c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; + } + if (d != NULL) { + mp_exch(d, &ta); + d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; + } +LBL_ERR: + mp_clear_multi(&ta, &tb, &tq, &q, NULL); + return res; +} + +#else + +/* integer signed division. + * c*b + d == a [e.g. a/b, c=quotient, d=remainder] + * HAC pp.598 Algorithm 14.20 + * + * Note that the description in HAC is horribly + * incomplete. For example, it doesn't consider + * the case where digits are removed from 'x' in + * the inner loop. It also doesn't consider the + * case that y has fewer than three digits, etc.. + * + * The overall algorithm is as described as + * 14.20 from HAC but fixed to treat these cases. +*/ +int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + mp_int q, x, y, t1, t2; + int res, n, t, i, norm, neg; + + /* is divisor zero ? */ + if (mp_iszero (b) == 1) { + return MP_VAL; + } + + /* if a < b then q=0, r = a */ + if (mp_cmp_mag (a, b) == MP_LT) { + if (d != NULL) { + res = mp_copy (a, d); + } else { + res = MP_OKAY; + } + if (c != NULL) { + mp_zero (c); + } + return res; + } + + if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) { + return res; + } + q.used = a->used + 2; + + if ((res = mp_init (&t1)) != MP_OKAY) { + goto LBL_Q; + } + + if ((res = mp_init (&t2)) != MP_OKAY) { + goto LBL_T1; + } + + if ((res = mp_init_copy (&x, a)) != MP_OKAY) { + goto LBL_T2; + } + + if ((res = mp_init_copy (&y, b)) != MP_OKAY) { + goto LBL_X; + } + + /* fix the sign */ + neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + x.sign = y.sign = MP_ZPOS; + + /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ + norm = mp_count_bits(&y) % DIGIT_BIT; + if (norm < (int)(DIGIT_BIT-1)) { + norm = (DIGIT_BIT-1) - norm; + if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) { + goto LBL_Y; + } + } else { + norm = 0; + } + + /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ + n = x.used - 1; + t = y.used - 1; + + /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */ + if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */ + goto LBL_Y; + } + + while (mp_cmp (&x, &y) != MP_LT) { + ++(q.dp[n - t]); + if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) { + goto LBL_Y; + } + } + + /* reset y by shifting it back down */ + mp_rshd (&y, n - t); + + /* step 3. for i from n down to (t + 1) */ + for (i = n; i >= (t + 1); i--) { + if (i > x.used) { + continue; + } + + /* step 3.1 if xi == yt then set q{i-t-1} to b-1, + * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ + if (x.dp[i] == y.dp[t]) { + q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1); + } else { + mp_word tmp; + tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT); + tmp |= ((mp_word) x.dp[i - 1]); + tmp /= ((mp_word) y.dp[t]); + if (tmp > (mp_word) MP_MASK) + tmp = MP_MASK; + q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK)); + } + + /* while (q{i-t-1} * (yt * b + y{t-1})) > + xi * b**2 + xi-1 * b + xi-2 + + do q{i-t-1} -= 1; + */ + q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK; + do { + q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK; + + /* find left hand */ + mp_zero (&t1); + t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1]; + t1.dp[1] = y.dp[t]; + t1.used = 2; + if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) { + goto LBL_Y; + } + + /* find right hand */ + t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2]; + t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1]; + t2.dp[2] = x.dp[i]; + t2.used = 3; + } while (mp_cmp_mag(&t1, &t2) == MP_GT); + + /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ + if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) { + goto LBL_Y; + } + + if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { + goto LBL_Y; + } + + if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) { + goto LBL_Y; + } + + /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */ + if (x.sign == MP_NEG) { + if ((res = mp_copy (&y, &t1)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) { + goto LBL_Y; + } + + q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK; + } + } + + /* now q is the quotient and x is the remainder + * [which we have to normalize] + */ + + /* get sign before writing to c */ + x.sign = x.used == 0 ? MP_ZPOS : a->sign; + + if (c != NULL) { + mp_clamp (&q); + mp_exch (&q, c); + c->sign = neg; + } + + if (d != NULL) { + mp_div_2d (&x, norm, &x, NULL); + mp_exch (&x, d); + } + + res = MP_OKAY; + +LBL_Y:mp_clear (&y); +LBL_X:mp_clear (&x); +LBL_T2:mp_clear (&t2); +LBL_T1:mp_clear (&t1); +LBL_Q:mp_clear (&q); + return res; +} + +#endif + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_div.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_div_2.c b/rts/ltm/bn_mp_div_2.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_div_2.c @@ -0,0 +1,68 @@ +#include +#ifdef BN_MP_DIV_2_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* b = a/2 */ +int mp_div_2(mp_int * a, mp_int * b) +{ + int x, res, oldused; + + /* copy */ + if (b->alloc < a->used) { + if ((res = mp_grow (b, a->used)) != MP_OKAY) { + return res; + } + } + + oldused = b->used; + b->used = a->used; + { + register mp_digit r, rr, *tmpa, *tmpb; + + /* source alias */ + tmpa = a->dp + b->used - 1; + + /* dest alias */ + tmpb = b->dp + b->used - 1; + + /* carry */ + r = 0; + for (x = b->used - 1; x >= 0; x--) { + /* get the carry for the next iteration */ + rr = *tmpa & 1; + + /* shift the current digit, add in carry and store */ + *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); + + /* forward carry to next iteration */ + r = rr; + } + + /* zero excess digits */ + tmpb = b->dp + b->used; + for (x = b->used; x < oldused; x++) { + *tmpb++ = 0; + } + } + b->sign = a->sign; + mp_clamp (b); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_div_2.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_div_2d.c b/rts/ltm/bn_mp_div_2d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_div_2d.c @@ -0,0 +1,97 @@ +#include +#ifdef BN_MP_DIV_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* shift right by a certain bit count (store quotient in c, optional remainder in d) */ +int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) +{ + mp_digit D, r, rr; + int x, res; + mp_int t; + + + /* if the shift count is <= 0 then we do no work */ + if (b <= 0) { + res = mp_copy (a, c); + if (d != NULL) { + mp_zero (d); + } + return res; + } + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + /* get the remainder */ + if (d != NULL) { + if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + } + + /* copy */ + if ((res = mp_copy (a, c)) != MP_OKAY) { + mp_clear (&t); + return res; + } + + /* shift by as many digits in the bit count */ + if (b >= (int)DIGIT_BIT) { + mp_rshd (c, b / DIGIT_BIT); + } + + /* shift any bit count < DIGIT_BIT */ + D = (mp_digit) (b % DIGIT_BIT); + if (D != 0) { + register mp_digit *tmpc, mask, shift; + + /* mask */ + mask = (((mp_digit)1) << D) - 1; + + /* shift for lsb */ + shift = DIGIT_BIT - D; + + /* alias */ + tmpc = c->dp + (c->used - 1); + + /* carry */ + r = 0; + for (x = c->used - 1; x >= 0; x--) { + /* get the lower bits of this word in a temp */ + rr = *tmpc & mask; + + /* shift the current word and mix in the carry bits from the previous word */ + *tmpc = (*tmpc >> D) | (r << shift); + --tmpc; + + /* set the carry to the carry bits of the current word found above */ + r = rr; + } + } + mp_clamp (c); + if (d != NULL) { + mp_exch (&t, d); + } + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_div_2d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_div_3.c b/rts/ltm/bn_mp_div_3.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_div_3.c @@ -0,0 +1,79 @@ +#include +#ifdef BN_MP_DIV_3_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* divide by three (based on routine from MPI and the GMP manual) */ +int +mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) +{ + mp_int q; + mp_word w, t; + mp_digit b; + int res, ix; + + /* b = 2**DIGIT_BIT / 3 */ + b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3); + + if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { + return res; + } + + q.used = a->used; + q.sign = a->sign; + w = 0; + for (ix = a->used - 1; ix >= 0; ix--) { + w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); + + if (w >= 3) { + /* multiply w by [1/3] */ + t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT); + + /* now subtract 3 * [w/3] from w, to get the remainder */ + w -= t+t+t; + + /* fixup the remainder as required since + * the optimization is not exact. + */ + while (w >= 3) { + t += 1; + w -= 3; + } + } else { + t = 0; + } + q.dp[ix] = (mp_digit)t; + } + + /* [optional] store the remainder */ + if (d != NULL) { + *d = (mp_digit)w; + } + + /* [optional] store the quotient */ + if (c != NULL) { + mp_clamp(&q); + mp_exch(&q, c); + } + mp_clear(&q); + + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_div_3.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_div_d.c b/rts/ltm/bn_mp_div_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_div_d.c @@ -0,0 +1,110 @@ +#include +#ifdef BN_MP_DIV_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +static int s_is_power_of_two(mp_digit b, int *p) +{ + int x; + + for (x = 1; x < DIGIT_BIT; x++) { + if (b == (((mp_digit)1)<dp[0] & ((((mp_digit)1)<used)) != MP_OKAY) { + return res; + } + + q.used = a->used; + q.sign = a->sign; + w = 0; + for (ix = a->used - 1; ix >= 0; ix--) { + w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); + + if (w >= b) { + t = (mp_digit)(w / b); + w -= ((mp_word)t) * ((mp_word)b); + } else { + t = 0; + } + q.dp[ix] = (mp_digit)t; + } + + if (d != NULL) { + *d = (mp_digit)w; + } + + if (c != NULL) { + mp_clamp(&q); + mp_exch(&q, c); + } + mp_clear(&q); + + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_div_d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_dr_is_modulus.c b/rts/ltm/bn_mp_dr_is_modulus.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_dr_is_modulus.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_DR_IS_MODULUS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines if a number is a valid DR modulus */ +int mp_dr_is_modulus(mp_int *a) +{ + int ix; + + /* must be at least two digits */ + if (a->used < 2) { + return 0; + } + + /* must be of the form b**k - a [a <= b] so all + * but the first digit must be equal to -1 (mod b). + */ + for (ix = 1; ix < a->used; ix++) { + if (a->dp[ix] != MP_MASK) { + return 0; + } + } + return 1; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_dr_is_modulus.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_dr_reduce.c b/rts/ltm/bn_mp_dr_reduce.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_dr_reduce.c @@ -0,0 +1,94 @@ +#include +#ifdef BN_MP_DR_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* reduce "x" in place modulo "n" using the Diminished Radix algorithm. + * + * Based on algorithm from the paper + * + * "Generating Efficient Primes for Discrete Log Cryptosystems" + * Chae Hoon Lim, Pil Joong Lee, + * POSTECH Information Research Laboratories + * + * The modulus must be of a special format [see manual] + * + * Has been modified to use algorithm 7.10 from the LTM book instead + * + * Input x must be in the range 0 <= x <= (n-1)**2 + */ +int +mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k) +{ + int err, i, m; + mp_word r; + mp_digit mu, *tmpx1, *tmpx2; + + /* m = digits in modulus */ + m = n->used; + + /* ensure that "x" has at least 2m digits */ + if (x->alloc < m + m) { + if ((err = mp_grow (x, m + m)) != MP_OKAY) { + return err; + } + } + +/* top of loop, this is where the code resumes if + * another reduction pass is required. + */ +top: + /* aliases for digits */ + /* alias for lower half of x */ + tmpx1 = x->dp; + + /* alias for upper half of x, or x/B**m */ + tmpx2 = x->dp + m; + + /* set carry to zero */ + mu = 0; + + /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ + for (i = 0; i < m; i++) { + r = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu; + *tmpx1++ = (mp_digit)(r & MP_MASK); + mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); + } + + /* set final carry */ + *tmpx1++ = mu; + + /* zero words above m */ + for (i = m + 1; i < x->used; i++) { + *tmpx1++ = 0; + } + + /* clamp, sub and return */ + mp_clamp (x); + + /* if x >= n then subtract and reduce again + * Each successive "recursion" makes the input smaller and smaller. + */ + if (mp_cmp_mag (x, n) != MP_LT) { + s_mp_sub(x, n, x); + goto top; + } + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_dr_reduce.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_dr_setup.c b/rts/ltm/bn_mp_dr_setup.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_dr_setup.c @@ -0,0 +1,32 @@ +#include +#ifdef BN_MP_DR_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines the setup value */ +void mp_dr_setup(mp_int *a, mp_digit *d) +{ + /* the casts are required if DIGIT_BIT is one less than + * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] + */ + *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - + ((mp_word)a->dp[0])); +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_dr_setup.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_exch.c b/rts/ltm/bn_mp_exch.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_exch.c @@ -0,0 +1,34 @@ +#include +#ifdef BN_MP_EXCH_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* swap the elements of two integers, for cases where you can't simply swap the + * mp_int pointers around + */ +void +mp_exch (mp_int * a, mp_int * b) +{ + mp_int t; + + t = *a; + *a = *b; + *b = t; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_exch.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_expt_d.c b/rts/ltm/bn_mp_expt_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_expt_d.c @@ -0,0 +1,57 @@ +#include +#ifdef BN_MP_EXPT_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* calculate c = a**b using a square-multiply algorithm */ +int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) +{ + int res, x; + mp_int g; + + if ((res = mp_init_copy (&g, a)) != MP_OKAY) { + return res; + } + + /* set initial result */ + mp_set (c, 1); + + for (x = 0; x < (int) DIGIT_BIT; x++) { + /* square */ + if ((res = mp_sqr (c, c)) != MP_OKAY) { + mp_clear (&g); + return res; + } + + /* if the bit is set multiply */ + if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) { + if ((res = mp_mul (c, &g, c)) != MP_OKAY) { + mp_clear (&g); + return res; + } + } + + /* shift to next bit */ + b <<= 1; + } + + mp_clear (&g); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_expt_d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_exptmod.c b/rts/ltm/bn_mp_exptmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_exptmod.c @@ -0,0 +1,112 @@ +#include +#ifdef BN_MP_EXPTMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + + +/* this is a shell function that calls either the normal or Montgomery + * exptmod functions. Originally the call to the montgomery code was + * embedded in the normal function but that wasted alot of stack space + * for nothing (since 99% of the time the Montgomery code would be called) + */ +int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) +{ + int dr; + + /* modulus P must be positive */ + if (P->sign == MP_NEG) { + return MP_VAL; + } + + /* if exponent X is negative we have to recurse */ + if (X->sign == MP_NEG) { +#ifdef BN_MP_INVMOD_C + mp_int tmpG, tmpX; + int err; + + /* first compute 1/G mod P */ + if ((err = mp_init(&tmpG)) != MP_OKAY) { + return err; + } + if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { + mp_clear(&tmpG); + return err; + } + + /* now get |X| */ + if ((err = mp_init(&tmpX)) != MP_OKAY) { + mp_clear(&tmpG); + return err; + } + if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { + mp_clear_multi(&tmpG, &tmpX, NULL); + return err; + } + + /* and now compute (1/G)**|X| instead of G**X [X < 0] */ + err = mp_exptmod(&tmpG, &tmpX, P, Y); + mp_clear_multi(&tmpG, &tmpX, NULL); + return err; +#else + /* no invmod */ + return MP_VAL; +#endif + } + +/* modified diminished radix reduction */ +#if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C) + if (mp_reduce_is_2k_l(P) == MP_YES) { + return s_mp_exptmod(G, X, P, Y, 1); + } +#endif + +#ifdef BN_MP_DR_IS_MODULUS_C + /* is it a DR modulus? */ + dr = mp_dr_is_modulus(P); +#else + /* default to no */ + dr = 0; +#endif + +#ifdef BN_MP_REDUCE_IS_2K_C + /* if not, is it a unrestricted DR modulus? */ + if (dr == 0) { + dr = mp_reduce_is_2k(P) << 1; + } +#endif + + /* if the modulus is odd or dr != 0 use the montgomery method */ +#ifdef BN_MP_EXPTMOD_FAST_C + if (mp_isodd (P) == 1 || dr != 0) { + return mp_exptmod_fast (G, X, P, Y, dr); + } else { +#endif +#ifdef BN_S_MP_EXPTMOD_C + /* otherwise use the generic Barrett reduction technique */ + return s_mp_exptmod (G, X, P, Y, 0); +#else + /* no exptmod for evens */ + return MP_VAL; +#endif +#ifdef BN_MP_EXPTMOD_FAST_C + } +#endif +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_exptmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_exptmod_fast.c b/rts/ltm/bn_mp_exptmod_fast.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_exptmod_fast.c @@ -0,0 +1,321 @@ +#include +#ifdef BN_MP_EXPTMOD_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 + * + * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. + * The value of k changes based on the size of the exponent. + * + * Uses Montgomery or Diminished Radix reduction [whichever appropriate] + */ + +#ifdef MP_LOW_MEM + #define TAB_SIZE 32 +#else + #define TAB_SIZE 256 +#endif + +int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) +{ + mp_int M[TAB_SIZE], res; + mp_digit buf, mp; + int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + + /* use a pointer to the reduction algorithm. This allows us to use + * one of many reduction algorithms without modding the guts of + * the code with if statements everywhere. + */ + int (*redux)(mp_int*,mp_int*,mp_digit); + + /* find window size */ + x = mp_count_bits (X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + +#ifdef MP_LOW_MEM + if (winsize > 5) { + winsize = 5; + } +#endif + + /* init M array */ + /* init first cell */ + if ((err = mp_init(&M[1])) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init(&M[x])) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear (&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* determine and setup reduction code */ + if (redmode == 0) { +#ifdef BN_MP_MONTGOMERY_SETUP_C + /* now setup montgomery */ + if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) { + goto LBL_M; + } +#else + err = MP_VAL; + goto LBL_M; +#endif + + /* automatically pick the comba one if available (saves quite a few calls/ifs) */ +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C + if (((P->used * 2 + 1) < MP_WARRAY) && + P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + redux = fast_mp_montgomery_reduce; + } else +#endif + { +#ifdef BN_MP_MONTGOMERY_REDUCE_C + /* use slower baseline Montgomery method */ + redux = mp_montgomery_reduce; +#else + err = MP_VAL; + goto LBL_M; +#endif + } + } else if (redmode == 1) { +#if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C) + /* setup DR reduction for moduli of the form B**k - b */ + mp_dr_setup(P, &mp); + redux = mp_dr_reduce; +#else + err = MP_VAL; + goto LBL_M; +#endif + } else { +#if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C) + /* setup DR reduction for moduli of the form 2**k - b */ + if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) { + goto LBL_M; + } + redux = mp_reduce_2k; +#else + err = MP_VAL; + goto LBL_M; +#endif + } + + /* setup result */ + if ((err = mp_init (&res)) != MP_OKAY) { + goto LBL_M; + } + + /* create M table + * + + * + * The first half of the table is not computed though accept for M[0] and M[1] + */ + + if (redmode == 0) { +#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C + /* now we need R mod m */ + if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) { + goto LBL_RES; + } +#else + err = MP_VAL; + goto LBL_RES; +#endif + + /* now set M[1] to G * R mod m */ + if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) { + goto LBL_RES; + } + } else { + mp_set(&res, 1); + if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { + goto LBL_RES; + } + } + + /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ + if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_RES; + } + + for (x = 0; x < (winsize - 1); x++) { + if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* create upper table */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&M[x], P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits so break */ + if (digidx == -1) { + break; + } + /* read next digit and reset bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int)DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if (mode == 0 && y == 0) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if (mode == 1 && y == 0) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* then multiply */ + if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if (mode == 2 && bitcpy > 0) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + + /* get next bit of the window */ + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + } + } + + if (redmode == 0) { + /* fixup result if Montgomery reduction is used + * recall that any value in a Montgomery system is + * actually multiplied by R mod n. So we have + * to reduce one more time to cancel out the factor + * of R. + */ + if ((err = redux(&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* swap res with Y */ + mp_exch (&res, Y); + err = MP_OKAY; +LBL_RES:mp_clear (&res); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear (&M[x]); + } + return err; +} +#endif + + +/* $Source: /cvs/libtom/libtommath/bn_mp_exptmod_fast.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_exteuclid.c b/rts/ltm/bn_mp_exteuclid.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_exteuclid.c @@ -0,0 +1,82 @@ +#include +#ifdef BN_MP_EXTEUCLID_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Extended euclidean algorithm of (a, b) produces + a*u1 + b*u2 = u3 + */ +int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) +{ + mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp; + int err; + + if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { + return err; + } + + /* initialize, (u1,u2,u3) = (1,0,a) */ + mp_set(&u1, 1); + if ((err = mp_copy(a, &u3)) != MP_OKAY) { goto _ERR; } + + /* initialize, (v1,v2,v3) = (0,1,b) */ + mp_set(&v2, 1); + if ((err = mp_copy(b, &v3)) != MP_OKAY) { goto _ERR; } + + /* loop while v3 != 0 */ + while (mp_iszero(&v3) == MP_NO) { + /* q = u3/v3 */ + if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { goto _ERR; } + + /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ + if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { goto _ERR; } + + /* (u1,u2,u3) = (v1,v2,v3) */ + if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { goto _ERR; } + + /* (v1,v2,v3) = (t1,t2,t3) */ + if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { goto _ERR; } + } + + /* make sure U3 >= 0 */ + if (u3.sign == MP_NEG) { + mp_neg(&u1, &u1); + mp_neg(&u2, &u2); + mp_neg(&u3, &u3); + } + + /* copy result out */ + if (U1 != NULL) { mp_exch(U1, &u1); } + if (U2 != NULL) { mp_exch(U2, &u2); } + if (U3 != NULL) { mp_exch(U3, &u3); } + + err = MP_OKAY; +_ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL); + return err; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_exteuclid.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_fread.c b/rts/ltm/bn_mp_fread.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_fread.c @@ -0,0 +1,67 @@ +#include +#ifdef BN_MP_FREAD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* read a bigint from a file stream in ASCII */ +int mp_fread(mp_int *a, int radix, FILE *stream) +{ + int err, ch, neg, y; + + /* clear a */ + mp_zero(a); + + /* if first digit is - then set negative */ + ch = fgetc(stream); + if (ch == '-') { + neg = MP_NEG; + ch = fgetc(stream); + } else { + neg = MP_ZPOS; + } + + for (;;) { + /* find y in the radix map */ + for (y = 0; y < radix; y++) { + if (mp_s_rmap[y] == ch) { + break; + } + } + if (y == radix) { + break; + } + + /* shift up and add */ + if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) { + return err; + } + if ((err = mp_add_d(a, y, a)) != MP_OKAY) { + return err; + } + + ch = fgetc(stream); + } + if (mp_cmp_d(a, 0) != MP_EQ) { + a->sign = neg; + } + + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_fread.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_fwrite.c b/rts/ltm/bn_mp_fwrite.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_fwrite.c @@ -0,0 +1,52 @@ +#include +#ifdef BN_MP_FWRITE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +int mp_fwrite(mp_int *a, int radix, FILE *stream) +{ + char *buf; + int err, len, x; + + if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { + return err; + } + + buf = OPT_CAST(char) XMALLOC (len); + if (buf == NULL) { + return MP_MEM; + } + + if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { + XFREE (buf); + return err; + } + + for (x = 0; x < len; x++) { + if (fputc(buf[x], stream) == EOF) { + XFREE (buf); + return MP_VAL; + } + } + + XFREE (buf); + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_fwrite.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_gcd.c b/rts/ltm/bn_mp_gcd.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_gcd.c @@ -0,0 +1,105 @@ +#include +#ifdef BN_MP_GCD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Greatest Common Divisor using the binary method */ +int mp_gcd (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int u, v; + int k, u_lsb, v_lsb, res; + + /* either zero than gcd is the largest */ + if (mp_iszero (a) == MP_YES) { + return mp_abs (b, c); + } + if (mp_iszero (b) == MP_YES) { + return mp_abs (a, c); + } + + /* get copies of a and b we can modify */ + if ((res = mp_init_copy (&u, a)) != MP_OKAY) { + return res; + } + + if ((res = mp_init_copy (&v, b)) != MP_OKAY) { + goto LBL_U; + } + + /* must be positive for the remainder of the algorithm */ + u.sign = v.sign = MP_ZPOS; + + /* B1. Find the common power of two for u and v */ + u_lsb = mp_cnt_lsb(&u); + v_lsb = mp_cnt_lsb(&v); + k = MIN(u_lsb, v_lsb); + + if (k > 0) { + /* divide the power of two out */ + if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { + goto LBL_V; + } + + if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + /* divide any remaining factors of two out */ + if (u_lsb != k) { + if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + if (v_lsb != k) { + if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + while (mp_iszero(&v) == 0) { + /* make sure v is the largest */ + if (mp_cmp_mag(&u, &v) == MP_GT) { + /* swap u and v to make sure v is >= u */ + mp_exch(&u, &v); + } + + /* subtract smallest from largest */ + if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) { + goto LBL_V; + } + + /* Divide out all factors of two */ + if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + /* multiply by 2**k which we divided out at the beginning */ + if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) { + goto LBL_V; + } + c->sign = MP_ZPOS; + res = MP_OKAY; +LBL_V:mp_clear (&u); +LBL_U:mp_clear (&v); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_gcd.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_get_int.c b/rts/ltm/bn_mp_get_int.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_get_int.c @@ -0,0 +1,45 @@ +#include +#ifdef BN_MP_GET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* get the lower 32-bits of an mp_int */ +unsigned long mp_get_int(mp_int * a) +{ + int i; + unsigned long res; + + if (a->used == 0) { + return 0; + } + + /* get number of digits of the lsb we have to read */ + i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1; + + /* get most significant digit of result */ + res = DIGIT(a,i); + + while (--i >= 0) { + res = (res << DIGIT_BIT) | DIGIT(a,i); + } + + /* force result to 32-bits always so it is consistent on non 32-bit platforms */ + return res & 0xFFFFFFFFUL; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_get_int.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_grow.c b/rts/ltm/bn_mp_grow.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_grow.c @@ -0,0 +1,57 @@ +#include +#ifdef BN_MP_GROW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* grow as required */ +int mp_grow (mp_int * a, int size) +{ + int i; + mp_digit *tmp; + + /* if the alloc size is smaller alloc more ram */ + if (a->alloc < size) { + /* ensure there are always at least MP_PREC digits extra on top */ + size += (MP_PREC * 2) - (size % MP_PREC); + + /* reallocate the array a->dp + * + * We store the return in a temporary variable + * in case the operation failed we don't want + * to overwrite the dp member of a. + */ + tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size); + if (tmp == NULL) { + /* reallocation failed but "a" is still valid [can be freed] */ + return MP_MEM; + } + + /* reallocation succeeded so set a->dp */ + a->dp = tmp; + + /* zero excess digits */ + i = a->alloc; + a->alloc = size; + for (; i < a->alloc; i++) { + a->dp[i] = 0; + } + } + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_grow.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_init.c b/rts/ltm/bn_mp_init.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_init.c @@ -0,0 +1,46 @@ +#include +#ifdef BN_MP_INIT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* init a new mp_int */ +int mp_init (mp_int * a) +{ + int i; + + /* allocate memory required and clear it */ + a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC); + if (a->dp == NULL) { + return MP_MEM; + } + + /* set the digits to zero */ + for (i = 0; i < MP_PREC; i++) { + a->dp[i] = 0; + } + + /* set the used to zero, allocated digits to the default precision + * and sign to positive */ + a->used = 0; + a->alloc = MP_PREC; + a->sign = MP_ZPOS; + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_init.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_init_copy.c b/rts/ltm/bn_mp_init_copy.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_init_copy.c @@ -0,0 +1,32 @@ +#include +#ifdef BN_MP_INIT_COPY_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* creates "a" then copies b into it */ +int mp_init_copy (mp_int * a, mp_int * b) +{ + int res; + + if ((res = mp_init (a)) != MP_OKAY) { + return res; + } + return mp_copy (b, a); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_init_copy.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_init_multi.c b/rts/ltm/bn_mp_init_multi.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_init_multi.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_INIT_MULTI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ +#include + +int mp_init_multi(mp_int *mp, ...) +{ + mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ + int n = 0; /* Number of ok inits */ + mp_int* cur_arg = mp; + va_list args; + + va_start(args, mp); /* init args to next argument from caller */ + while (cur_arg != NULL) { + if (mp_init(cur_arg) != MP_OKAY) { + /* Oops - error! Back-track and mp_clear what we already + succeeded in init-ing, then return error. + */ + va_list clean_args; + + /* end the current list */ + va_end(args); + + /* now start cleaning up */ + cur_arg = mp; + va_start(clean_args, mp); + while (n--) { + mp_clear(cur_arg); + cur_arg = va_arg(clean_args, mp_int*); + } + va_end(clean_args); + res = MP_MEM; + break; + } + n++; + cur_arg = va_arg(args, mp_int*); + } + va_end(args); + return res; /* Assumed ok, if error flagged above. */ +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_init_multi.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_init_set.c b/rts/ltm/bn_mp_init_set.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_init_set.c @@ -0,0 +1,32 @@ +#include +#ifdef BN_MP_INIT_SET_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* initialize and set a digit */ +int mp_init_set (mp_int * a, mp_digit b) +{ + int err; + if ((err = mp_init(a)) != MP_OKAY) { + return err; + } + mp_set(a, b); + return err; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_init_set.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_init_set_int.c b/rts/ltm/bn_mp_init_set_int.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_init_set_int.c @@ -0,0 +1,31 @@ +#include +#ifdef BN_MP_INIT_SET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* initialize and set a digit */ +int mp_init_set_int (mp_int * a, unsigned long b) +{ + int err; + if ((err = mp_init(a)) != MP_OKAY) { + return err; + } + return mp_set_int(a, b); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_init_set_int.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_init_size.c b/rts/ltm/bn_mp_init_size.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_init_size.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_INIT_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* init an mp_init for a given size */ +int mp_init_size (mp_int * a, int size) +{ + int x; + + /* pad size so there are always extra digits */ + size += (MP_PREC * 2) - (size % MP_PREC); + + /* alloc mem */ + a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size); + if (a->dp == NULL) { + return MP_MEM; + } + + /* set the members */ + a->used = 0; + a->alloc = size; + a->sign = MP_ZPOS; + + /* zero the digits */ + for (x = 0; x < size; x++) { + a->dp[x] = 0; + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_init_size.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_invmod.c b/rts/ltm/bn_mp_invmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_invmod.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_INVMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* hac 14.61, pp608 */ +int mp_invmod (mp_int * a, mp_int * b, mp_int * c) +{ + /* b cannot be negative */ + if (b->sign == MP_NEG || mp_iszero(b) == 1) { + return MP_VAL; + } + +#ifdef BN_FAST_MP_INVMOD_C + /* if the modulus is odd we can use a faster routine instead */ + if (mp_isodd (b) == 1) { + return fast_mp_invmod (a, b, c); + } +#endif + +#ifdef BN_MP_INVMOD_SLOW_C + return mp_invmod_slow(a, b, c); +#endif + + return MP_VAL; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_invmod.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_invmod_slow.c b/rts/ltm/bn_mp_invmod_slow.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_invmod_slow.c @@ -0,0 +1,175 @@ +#include +#ifdef BN_MP_INVMOD_SLOW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* hac 14.61, pp608 */ +int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x, y, u, v, A, B, C, D; + int res; + + /* b cannot be negative */ + if (b->sign == MP_NEG || mp_iszero(b) == 1) { + return MP_VAL; + } + + /* init temps */ + if ((res = mp_init_multi(&x, &y, &u, &v, + &A, &B, &C, &D, NULL)) != MP_OKAY) { + return res; + } + + /* x = a, y = b */ + if ((res = mp_mod(a, b, &x)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (b, &y)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 2. [modified] if x,y are both even then return an error! */ + if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) { + res = MP_VAL; + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((res = mp_copy (&x, &u)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (&y, &v)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set (&A, 1); + mp_set (&D, 1); + +top: + /* 4. while u is even do */ + while (mp_iseven (&u) == 1) { + /* 4.1 u = u/2 */ + if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { + goto LBL_ERR; + } + /* 4.2 if A or B is odd then */ + if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) { + /* A = (A+y)/2, B = (B-x)/2 */ + if ((res = mp_add (&A, &y, &A)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* A = A/2, B = B/2 */ + if ((res = mp_div_2 (&A, &A)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 5. while v is even do */ + while (mp_iseven (&v) == 1) { + /* 5.1 v = v/2 */ + if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { + goto LBL_ERR; + } + /* 5.2 if C or D is odd then */ + if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) { + /* C = (C+y)/2, D = (D-x)/2 */ + if ((res = mp_add (&C, &y, &C)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* C = C/2, D = D/2 */ + if ((res = mp_div_2 (&C, &C)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 6. if u >= v then */ + if (mp_cmp (&u, &v) != MP_LT) { + /* u = u - v, A = A - C, B = B - D */ + if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } else { + /* v - v - u, C = C - A, D = D - B */ + if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* if not zero goto step 4 */ + if (mp_iszero (&u) == 0) + goto top; + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d (&v, 1) != MP_EQ) { + res = MP_VAL; + goto LBL_ERR; + } + + /* if its too low */ + while (mp_cmp_d(&C, 0) == MP_LT) { + if ((res = mp_add(&C, b, &C)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* too big */ + while (mp_cmp_mag(&C, b) != MP_LT) { + if ((res = mp_sub(&C, b, &C)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* C is now the inverse */ + mp_exch (&C, c); + res = MP_OKAY; +LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_invmod_slow.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_is_square.c b/rts/ltm/bn_mp_is_square.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_is_square.c @@ -0,0 +1,109 @@ +#include +#ifdef BN_MP_IS_SQUARE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Check if remainders are possible squares - fast exclude non-squares */ +static const char rem_128[128] = { + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1 +}; + +static const char rem_105[105] = { + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, + 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, + 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 +}; + +/* Store non-zero to ret if arg is square, and zero if not */ +int mp_is_square(mp_int *arg,int *ret) +{ + int res; + mp_digit c; + mp_int t; + unsigned long r; + + /* Default to Non-square :) */ + *ret = MP_NO; + + if (arg->sign == MP_NEG) { + return MP_VAL; + } + + /* digits used? (TSD) */ + if (arg->used == 0) { + return MP_OKAY; + } + + /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ + if (rem_128[127 & DIGIT(arg,0)] == 1) { + return MP_OKAY; + } + + /* Next check mod 105 (3*5*7) */ + if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) { + return res; + } + if (rem_105[c] == 1) { + return MP_OKAY; + } + + + if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { + return res; + } + if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) { + goto ERR; + } + r = mp_get_int(&t); + /* Check for other prime modules, note it's not an ERROR but we must + * free "t" so the easiest way is to goto ERR. We know that res + * is already equal to MP_OKAY from the mp_mod call + */ + if ( (1L<<(r%11)) & 0x5C4L ) goto ERR; + if ( (1L<<(r%13)) & 0x9E4L ) goto ERR; + if ( (1L<<(r%17)) & 0x5CE8L ) goto ERR; + if ( (1L<<(r%19)) & 0x4F50CL ) goto ERR; + if ( (1L<<(r%23)) & 0x7ACCA0L ) goto ERR; + if ( (1L<<(r%29)) & 0xC2EDD0CL ) goto ERR; + if ( (1L<<(r%31)) & 0x6DE2B848L ) goto ERR; + + /* Final check - is sqr(sqrt(arg)) == arg ? */ + if ((res = mp_sqrt(arg,&t)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sqr(&t,&t)) != MP_OKAY) { + goto ERR; + } + + *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO; +ERR:mp_clear(&t); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_is_square.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_jacobi.c b/rts/ltm/bn_mp_jacobi.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_jacobi.c @@ -0,0 +1,105 @@ +#include +#ifdef BN_MP_JACOBI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes the jacobi c = (a | n) (or Legendre if n is prime) + * HAC pp. 73 Algorithm 2.149 + */ +int mp_jacobi (mp_int * a, mp_int * p, int *c) +{ + mp_int a1, p1; + int k, s, r, res; + mp_digit residue; + + /* if p <= 0 return MP_VAL */ + if (mp_cmp_d(p, 0) != MP_GT) { + return MP_VAL; + } + + /* step 1. if a == 0, return 0 */ + if (mp_iszero (a) == 1) { + *c = 0; + return MP_OKAY; + } + + /* step 2. if a == 1, return 1 */ + if (mp_cmp_d (a, 1) == MP_EQ) { + *c = 1; + return MP_OKAY; + } + + /* default */ + s = 0; + + /* step 3. write a = a1 * 2**k */ + if ((res = mp_init_copy (&a1, a)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&p1)) != MP_OKAY) { + goto LBL_A1; + } + + /* divide out larger power of two */ + k = mp_cnt_lsb(&a1); + if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { + goto LBL_P1; + } + + /* step 4. if e is even set s=1 */ + if ((k & 1) == 0) { + s = 1; + } else { + /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ + residue = p->dp[0] & 7; + + if (residue == 1 || residue == 7) { + s = 1; + } else if (residue == 3 || residue == 5) { + s = -1; + } + } + + /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ + if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) { + s = -s; + } + + /* if a1 == 1 we're done */ + if (mp_cmp_d (&a1, 1) == MP_EQ) { + *c = s; + } else { + /* n1 = n mod a1 */ + if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) { + goto LBL_P1; + } + if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) { + goto LBL_P1; + } + *c = s * r; + } + + /* done */ + res = MP_OKAY; +LBL_P1:mp_clear (&p1); +LBL_A1:mp_clear (&a1); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_jacobi.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_karatsuba_mul.c b/rts/ltm/bn_mp_karatsuba_mul.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_karatsuba_mul.c @@ -0,0 +1,167 @@ +#include +#ifdef BN_MP_KARATSUBA_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* c = |a| * |b| using Karatsuba Multiplication using + * three half size multiplications + * + * Let B represent the radix [e.g. 2**DIGIT_BIT] and + * let n represent half of the number of digits in + * the min(a,b) + * + * a = a1 * B**n + a0 + * b = b1 * B**n + b0 + * + * Then, a * b => + a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 + * + * Note that a1b1 and a0b0 are used twice and only need to be + * computed once. So in total three half size (half # of + * digit) multiplications are performed, a0b0, a1b1 and + * (a1+b1)(a0+b0) + * + * Note that a multiplication of half the digits requires + * 1/4th the number of single precision multiplications so in + * total after one call 25% of the single precision multiplications + * are saved. Note also that the call to mp_mul can end up back + * in this function if the a0, a1, b0, or b1 are above the threshold. + * This is known as divide-and-conquer and leads to the famous + * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than + * the standard O(N**2) that the baseline/comba methods use. + * Generally though the overhead of this method doesn't pay off + * until a certain size (N ~ 80) is reached. + */ +int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x0, x1, y0, y1, t1, x0y0, x1y1; + int B, err; + + /* default the return code to an error */ + err = MP_MEM; + + /* min # of digits */ + B = MIN (a->used, b->used); + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size (&x0, B) != MP_OKAY) + goto ERR; + if (mp_init_size (&x1, a->used - B) != MP_OKAY) + goto X0; + if (mp_init_size (&y0, B) != MP_OKAY) + goto X1; + if (mp_init_size (&y1, b->used - B) != MP_OKAY) + goto Y0; + + /* init temps */ + if (mp_init_size (&t1, B * 2) != MP_OKAY) + goto Y1; + if (mp_init_size (&x0y0, B * 2) != MP_OKAY) + goto T1; + if (mp_init_size (&x1y1, B * 2) != MP_OKAY) + goto X0Y0; + + /* now shift the digits */ + x0.used = y0.used = B; + x1.used = a->used - B; + y1.used = b->used - B; + + { + register int x; + register mp_digit *tmpa, *tmpb, *tmpx, *tmpy; + + /* we copy the digits directly instead of using higher level functions + * since we also need to shift the digits + */ + tmpa = a->dp; + tmpb = b->dp; + + tmpx = x0.dp; + tmpy = y0.dp; + for (x = 0; x < B; x++) { + *tmpx++ = *tmpa++; + *tmpy++ = *tmpb++; + } + + tmpx = x1.dp; + for (x = B; x < a->used; x++) { + *tmpx++ = *tmpa++; + } + + tmpy = y1.dp; + for (x = B; x < b->used; x++) { + *tmpy++ = *tmpb++; + } + } + + /* only need to clamp the lower words since by definition the + * upper words x1/y1 must have a known number of digits + */ + mp_clamp (&x0); + mp_clamp (&y0); + + /* now calc the products x0y0 and x1y1 */ + /* after this x0 is no longer required, free temp [x0==t2]! */ + if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY) + goto X1Y1; /* x0y0 = x0*y0 */ + if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY) + goto X1Y1; /* x1y1 = x1*y1 */ + + /* now calc x1+x0 and y1+y0 */ + if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = x1 - x0 */ + if (s_mp_add (&y1, &y0, &x0) != MP_OKAY) + goto X1Y1; /* t2 = y1 - y0 */ + if (mp_mul (&t1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ + + /* add x0y0 */ + if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY) + goto X1Y1; /* t2 = x0y0 + x1y1 */ + if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ + + /* shift by B */ + if (mp_lshd (&t1, B) != MP_OKAY) + goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))< +#ifdef BN_MP_KARATSUBA_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Karatsuba squaring, computes b = a*a using three + * half size squarings + * + * See comments of karatsuba_mul for details. It + * is essentially the same algorithm but merely + * tuned to perform recursive squarings. + */ +int mp_karatsuba_sqr (mp_int * a, mp_int * b) +{ + mp_int x0, x1, t1, t2, x0x0, x1x1; + int B, err; + + err = MP_MEM; + + /* min # of digits */ + B = a->used; + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size (&x0, B) != MP_OKAY) + goto ERR; + if (mp_init_size (&x1, a->used - B) != MP_OKAY) + goto X0; + + /* init temps */ + if (mp_init_size (&t1, a->used * 2) != MP_OKAY) + goto X1; + if (mp_init_size (&t2, a->used * 2) != MP_OKAY) + goto T1; + if (mp_init_size (&x0x0, B * 2) != MP_OKAY) + goto T2; + if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY) + goto X0X0; + + { + register int x; + register mp_digit *dst, *src; + + src = a->dp; + + /* now shift the digits */ + dst = x0.dp; + for (x = 0; x < B; x++) { + *dst++ = *src++; + } + + dst = x1.dp; + for (x = B; x < a->used; x++) { + *dst++ = *src++; + } + } + + x0.used = B; + x1.used = a->used - B; + + mp_clamp (&x0); + + /* now calc the products x0*x0 and x1*x1 */ + if (mp_sqr (&x0, &x0x0) != MP_OKAY) + goto X1X1; /* x0x0 = x0*x0 */ + if (mp_sqr (&x1, &x1x1) != MP_OKAY) + goto X1X1; /* x1x1 = x1*x1 */ + + /* now calc (x1+x0)**2 */ + if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) + goto X1X1; /* t1 = x1 - x0 */ + if (mp_sqr (&t1, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ + + /* add x0y0 */ + if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY) + goto X1X1; /* t2 = x0x0 + x1x1 */ + if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ + + /* shift by B */ + if (mp_lshd (&t1, B) != MP_OKAY) + goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))< +#ifdef BN_MP_LCM_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes least common multiple as |a*b|/(a, b) */ +int mp_lcm (mp_int * a, mp_int * b, mp_int * c) +{ + int res; + mp_int t1, t2; + + + if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) { + return res; + } + + /* t1 = get the GCD of the two inputs */ + if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) { + goto LBL_T; + } + + /* divide the smallest by the GCD */ + if (mp_cmp_mag(a, b) == MP_LT) { + /* store quotient in t2 such that t2 * b is the LCM */ + if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { + goto LBL_T; + } + res = mp_mul(b, &t2, c); + } else { + /* store quotient in t2 such that t2 * a is the LCM */ + if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { + goto LBL_T; + } + res = mp_mul(a, &t2, c); + } + + /* fix the sign to positive */ + c->sign = MP_ZPOS; + +LBL_T: + mp_clear_multi (&t1, &t2, NULL); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_lcm.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_lshd.c b/rts/ltm/bn_mp_lshd.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_lshd.c @@ -0,0 +1,67 @@ +#include +#ifdef BN_MP_LSHD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* shift left a certain amount of digits */ +int mp_lshd (mp_int * a, int b) +{ + int x, res; + + /* if its less than zero return */ + if (b <= 0) { + return MP_OKAY; + } + + /* grow to fit the new digits */ + if (a->alloc < a->used + b) { + if ((res = mp_grow (a, a->used + b)) != MP_OKAY) { + return res; + } + } + + { + register mp_digit *top, *bottom; + + /* increment the used by the shift amount then copy upwards */ + a->used += b; + + /* top */ + top = a->dp + a->used - 1; + + /* base */ + bottom = a->dp + a->used - 1 - b; + + /* much like mp_rshd this is implemented using a sliding window + * except the window goes the otherway around. Copying from + * the bottom to the top. see bn_mp_rshd.c for more info. + */ + for (x = a->used - 1; x >= b; x--) { + *top-- = *bottom--; + } + + /* zero the lower digits */ + top = a->dp; + for (x = 0; x < b; x++) { + *top++ = 0; + } + } + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_lshd.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mod.c b/rts/ltm/bn_mp_mod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mod.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_MOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* c = a mod b, 0 <= c < b */ +int +mp_mod (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int t; + int res; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + + if (t.sign != b->sign) { + res = mp_add (b, &t, c); + } else { + res = MP_OKAY; + mp_exch (&t, c); + } + + mp_clear (&t); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mod.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mod_2d.c b/rts/ltm/bn_mp_mod_2d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mod_2d.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_MOD_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* calc a value mod 2**b */ +int +mp_mod_2d (mp_int * a, int b, mp_int * c) +{ + int x, res; + + /* if b is <= 0 then zero the int */ + if (b <= 0) { + mp_zero (c); + return MP_OKAY; + } + + /* if the modulus is larger than the value than return */ + if (b >= (int) (a->used * DIGIT_BIT)) { + res = mp_copy (a, c); + return res; + } + + /* copy */ + if ((res = mp_copy (a, c)) != MP_OKAY) { + return res; + } + + /* zero digits above the last digit of the modulus */ + for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) { + c->dp[x] = 0; + } + /* clear the digit that is not completely outside/inside the modulus */ + c->dp[b / DIGIT_BIT] &= + (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1)); + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mod_2d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mod_d.c b/rts/ltm/bn_mp_mod_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mod_d.c @@ -0,0 +1,27 @@ +#include +#ifdef BN_MP_MOD_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +int +mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) +{ + return mp_div_d(a, b, NULL, c); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mod_d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_montgomery_calc_normalization.c b/rts/ltm/bn_mp_montgomery_calc_normalization.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_montgomery_calc_normalization.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* + * shifts with subtractions when the result is greater than b. + * + * The method is slightly modified to shift B unconditionally upto just under + * the leading bit of b. This saves alot of multiple precision shifting. + */ +int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) +{ + int x, bits, res; + + /* how many bits of last digit does b use */ + bits = mp_count_bits (b) % DIGIT_BIT; + + if (b->used > 1) { + if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) { + return res; + } + } else { + mp_set(a, 1); + bits = 1; + } + + + /* now compute C = A * B mod b */ + for (x = bits - 1; x < (int)DIGIT_BIT; x++) { + if ((res = mp_mul_2 (a, a)) != MP_OKAY) { + return res; + } + if (mp_cmp_mag (a, b) != MP_LT) { + if ((res = s_mp_sub (a, b, a)) != MP_OKAY) { + return res; + } + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_montgomery_reduce.c b/rts/ltm/bn_mp_montgomery_reduce.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_montgomery_reduce.c @@ -0,0 +1,118 @@ +#include +#ifdef BN_MP_MONTGOMERY_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes xR**-1 == x (mod N) via Montgomery Reduction */ +int +mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +{ + int ix, res, digs; + mp_digit mu; + + /* can the fast reduction [comba] method be used? + * + * Note that unlike in mul you're safely allowed *less* + * than the available columns [255 per default] since carries + * are fixed up in the inner loop. + */ + digs = n->used * 2 + 1; + if ((digs < MP_WARRAY) && + n->used < + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_mp_montgomery_reduce (x, n, rho); + } + + /* grow the input as required */ + if (x->alloc < digs) { + if ((res = mp_grow (x, digs)) != MP_OKAY) { + return res; + } + } + x->used = digs; + + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * rho mod b + * + * The value of rho must be precalculated via + * montgomery_setup() such that + * it equals -1/n0 mod b this allows the + * following inner loop to reduce the + * input one digit at a time + */ + mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK); + + /* a = a + mu * m * b**i */ + { + register int iy; + register mp_digit *tmpn, *tmpx, u; + register mp_word r; + + /* alias for digits of the modulus */ + tmpn = n->dp; + + /* alias for the digits of x [the input] */ + tmpx = x->dp + ix; + + /* set the carry to zero */ + u = 0; + + /* Multiply and add in place */ + for (iy = 0; iy < n->used; iy++) { + /* compute product and sum */ + r = ((mp_word)mu) * ((mp_word)*tmpn++) + + ((mp_word) u) + ((mp_word) * tmpx); + + /* get carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + + /* fix digit */ + *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK)); + } + /* At this point the ix'th digit of x should be zero */ + + + /* propagate carries upwards as required*/ + while (u) { + *tmpx += u; + u = *tmpx >> DIGIT_BIT; + *tmpx++ &= MP_MASK; + } + } + } + + /* at this point the n.used'th least + * significant digits of x are all zero + * which means we can shift x to the + * right by n.used digits and the + * residue is unchanged. + */ + + /* x = x/b**n.used */ + mp_clamp(x); + mp_rshd (x, n->used); + + /* if x >= n then x = x - n */ + if (mp_cmp_mag (x, n) != MP_LT) { + return s_mp_sub (x, n, x); + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_montgomery_setup.c b/rts/ltm/bn_mp_montgomery_setup.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_montgomery_setup.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_MONTGOMERY_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* setups the montgomery reduction stuff */ +int +mp_montgomery_setup (mp_int * n, mp_digit * rho) +{ + mp_digit x, b; + +/* fast inversion mod 2**k + * + * Based on the fact that + * + * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) + * => 2*X*A - X*X*A*A = 1 + * => 2*(1) - (1) = 1 + */ + b = n->dp[0]; + + if ((b & 1) == 0) { + return MP_VAL; + } + + x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */ + x *= 2 - b * x; /* here x*a==1 mod 2**8 */ +#if !defined(MP_8BIT) + x *= 2 - b * x; /* here x*a==1 mod 2**16 */ +#endif +#if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) + x *= 2 - b * x; /* here x*a==1 mod 2**32 */ +#endif +#ifdef MP_64BIT + x *= 2 - b * x; /* here x*a==1 mod 2**64 */ +#endif + + /* rho = -1/m mod b */ + *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_montgomery_setup.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mul.c b/rts/ltm/bn_mp_mul.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mul.c @@ -0,0 +1,66 @@ +#include +#ifdef BN_MP_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* high level multiplication (handles sign) */ +int mp_mul (mp_int * a, mp_int * b, mp_int * c) +{ + int res, neg; + neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + + /* use Toom-Cook? */ +#ifdef BN_MP_TOOM_MUL_C + if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) { + res = mp_toom_mul(a, b, c); + } else +#endif +#ifdef BN_MP_KARATSUBA_MUL_C + /* use Karatsuba? */ + if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) { + res = mp_karatsuba_mul (a, b, c); + } else +#endif + { + /* can we use the fast multiplier? + * + * The fast multiplier can be used if the output will + * have less than MP_WARRAY digits and the number of + * digits won't affect carry propagation + */ + int digs = a->used + b->used + 1; + +#ifdef BN_FAST_S_MP_MUL_DIGS_C + if ((digs < MP_WARRAY) && + MIN(a->used, b->used) <= + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + res = fast_s_mp_mul_digs (a, b, c, digs); + } else +#endif +#ifdef BN_S_MP_MUL_DIGS_C + res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */ +#else + res = MP_VAL; +#endif + + } + c->sign = (c->used > 0) ? neg : MP_ZPOS; + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mul.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mul_2.c b/rts/ltm/bn_mp_mul_2.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mul_2.c @@ -0,0 +1,82 @@ +#include +#ifdef BN_MP_MUL_2_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* b = a*2 */ +int mp_mul_2(mp_int * a, mp_int * b) +{ + int x, res, oldused; + + /* grow to accomodate result */ + if (b->alloc < a->used + 1) { + if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) { + return res; + } + } + + oldused = b->used; + b->used = a->used; + + { + register mp_digit r, rr, *tmpa, *tmpb; + + /* alias for source */ + tmpa = a->dp; + + /* alias for dest */ + tmpb = b->dp; + + /* carry */ + r = 0; + for (x = 0; x < a->used; x++) { + + /* get what will be the *next* carry bit from the + * MSB of the current digit + */ + rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1)); + + /* now shift up this digit, add in the carry [from the previous] */ + *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK; + + /* copy the carry that would be from the source + * digit into the next iteration + */ + r = rr; + } + + /* new leading digit? */ + if (r != 0) { + /* add a MSB which is always 1 at this point */ + *tmpb = 1; + ++(b->used); + } + + /* now zero any excess digits on the destination + * that we didn't write to + */ + tmpb = b->dp + b->used; + for (x = b->used; x < oldused; x++) { + *tmpb++ = 0; + } + } + b->sign = a->sign; + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mul_2d.c b/rts/ltm/bn_mp_mul_2d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mul_2d.c @@ -0,0 +1,85 @@ +#include +#ifdef BN_MP_MUL_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* shift left by a certain bit count */ +int mp_mul_2d (mp_int * a, int b, mp_int * c) +{ + mp_digit d; + int res; + + /* copy */ + if (a != c) { + if ((res = mp_copy (a, c)) != MP_OKAY) { + return res; + } + } + + if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) { + if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) { + return res; + } + } + + /* shift by as many digits in the bit count */ + if (b >= (int)DIGIT_BIT) { + if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) { + return res; + } + } + + /* shift any bit count < DIGIT_BIT */ + d = (mp_digit) (b % DIGIT_BIT); + if (d != 0) { + register mp_digit *tmpc, shift, mask, r, rr; + register int x; + + /* bitmask for carries */ + mask = (((mp_digit)1) << d) - 1; + + /* shift for msbs */ + shift = DIGIT_BIT - d; + + /* alias */ + tmpc = c->dp; + + /* carry */ + r = 0; + for (x = 0; x < c->used; x++) { + /* get the higher bits of the current word */ + rr = (*tmpc >> shift) & mask; + + /* shift the current word and OR in the carry */ + *tmpc = ((*tmpc << d) | r) & MP_MASK; + ++tmpc; + + /* set the carry to the carry bits of the current word */ + r = rr; + } + + /* set final carry */ + if (r != 0) { + c->dp[(c->used)++] = r; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_2d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mul_d.c b/rts/ltm/bn_mp_mul_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mul_d.c @@ -0,0 +1,79 @@ +#include +#ifdef BN_MP_MUL_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* multiply by a digit */ +int +mp_mul_d (mp_int * a, mp_digit b, mp_int * c) +{ + mp_digit u, *tmpa, *tmpc; + mp_word r; + int ix, res, olduse; + + /* make sure c is big enough to hold a*b */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* get the original destinations used count */ + olduse = c->used; + + /* set the sign */ + c->sign = a->sign; + + /* alias for a->dp [source] */ + tmpa = a->dp; + + /* alias for c->dp [dest] */ + tmpc = c->dp; + + /* zero carry */ + u = 0; + + /* compute columns */ + for (ix = 0; ix < a->used; ix++) { + /* compute product and carry sum for this term */ + r = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b); + + /* mask off higher bits to get a single digit */ + *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* send carry into next iteration */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + + /* store final carry [if any] and increment ix offset */ + *tmpc++ = u; + ++ix; + + /* now zero digits above the top */ + while (ix++ < olduse) { + *tmpc++ = 0; + } + + /* set used count */ + c->used = a->used + 1; + mp_clamp(c); + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mul_d.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_mulmod.c b/rts/ltm/bn_mp_mulmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_mulmod.c @@ -0,0 +1,40 @@ +#include +#ifdef BN_MP_MULMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* d = a * b (mod c) */ +int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_mul (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_mulmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_n_root.c b/rts/ltm/bn_mp_n_root.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_n_root.c @@ -0,0 +1,132 @@ +#include +#ifdef BN_MP_N_ROOT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* find the n'th root of an integer + * + * Result found such that (c)**b <= a and (c+1)**b > a + * + * This algorithm uses Newton's approximation + * x[i+1] = x[i] - f(x[i])/f'(x[i]) + * which will find the root in log(N) time where + * each step involves a fair bit. This is not meant to + * find huge roots [square and cube, etc]. + */ +int mp_n_root (mp_int * a, mp_digit b, mp_int * c) +{ + mp_int t1, t2, t3; + int res, neg; + + /* input must be positive if b is even */ + if ((b & 1) == 0 && a->sign == MP_NEG) { + return MP_VAL; + } + + if ((res = mp_init (&t1)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&t2)) != MP_OKAY) { + goto LBL_T1; + } + + if ((res = mp_init (&t3)) != MP_OKAY) { + goto LBL_T2; + } + + /* if a is negative fudge the sign but keep track */ + neg = a->sign; + a->sign = MP_ZPOS; + + /* t2 = 2 */ + mp_set (&t2, 2); + + do { + /* t1 = t2 */ + if ((res = mp_copy (&t2, &t1)) != MP_OKAY) { + goto LBL_T3; + } + + /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ + + /* t3 = t1**(b-1) */ + if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) { + goto LBL_T3; + } + + /* numerator */ + /* t2 = t1**b */ + if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + /* t2 = t1**b - a */ + if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + /* denominator */ + /* t3 = t1**(b-1) * b */ + if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) { + goto LBL_T3; + } + + /* t3 = (t1**b - a)/(b * t1**(b-1)) */ + if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) { + goto LBL_T3; + } + + if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) { + goto LBL_T3; + } + } while (mp_cmp (&t1, &t2) != MP_EQ); + + /* result can be off by a few so check */ + for (;;) { + if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + if (mp_cmp (&t2, a) == MP_GT) { + if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) { + goto LBL_T3; + } + } else { + break; + } + } + + /* reset the sign of a first */ + a->sign = neg; + + /* set the result */ + mp_exch (&t1, c); + + /* set the sign of the result */ + c->sign = neg; + + res = MP_OKAY; + +LBL_T3:mp_clear (&t3); +LBL_T2:mp_clear (&t2); +LBL_T1:mp_clear (&t1); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_n_root.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_neg.c b/rts/ltm/bn_mp_neg.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_neg.c @@ -0,0 +1,40 @@ +#include +#ifdef BN_MP_NEG_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* b = -a */ +int mp_neg (mp_int * a, mp_int * b) +{ + int res; + if (a != b) { + if ((res = mp_copy (a, b)) != MP_OKAY) { + return res; + } + } + + if (mp_iszero(b) != MP_YES) { + b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; + } else { + b->sign = MP_ZPOS; + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_neg.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_or.c b/rts/ltm/bn_mp_or.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_or.c @@ -0,0 +1,50 @@ +#include +#ifdef BN_MP_OR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* OR two ints together */ +int mp_or (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] |= x->dp[ix]; + } + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_or.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_prime_fermat.c b/rts/ltm/bn_mp_prime_fermat.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_prime_fermat.c @@ -0,0 +1,62 @@ +#include +#ifdef BN_MP_PRIME_FERMAT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* performs one Fermat test. + * + * If "a" were prime then b**a == b (mod a) since the order of + * the multiplicative sub-group would be phi(a) = a-1. That means + * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). + * + * Sets result to 1 if the congruence holds, or zero otherwise. + */ +int mp_prime_fermat (mp_int * a, mp_int * b, int *result) +{ + mp_int t; + int err; + + /* default to composite */ + *result = MP_NO; + + /* ensure b > 1 */ + if (mp_cmp_d(b, 1) != MP_GT) { + return MP_VAL; + } + + /* init t */ + if ((err = mp_init (&t)) != MP_OKAY) { + return err; + } + + /* compute t = b**a mod a */ + if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) { + goto LBL_T; + } + + /* is it equal to b? */ + if (mp_cmp (&t, b) == MP_EQ) { + *result = MP_YES; + } + + err = MP_OKAY; +LBL_T:mp_clear (&t); + return err; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_fermat.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_prime_is_divisible.c b/rts/ltm/bn_mp_prime_is_divisible.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_prime_is_divisible.c @@ -0,0 +1,50 @@ +#include +#ifdef BN_MP_PRIME_IS_DIVISIBLE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines if an integers is divisible by one + * of the first PRIME_SIZE primes or not + * + * sets result to 0 if not, 1 if yes + */ +int mp_prime_is_divisible (mp_int * a, int *result) +{ + int err, ix; + mp_digit res; + + /* default to not */ + *result = MP_NO; + + for (ix = 0; ix < PRIME_SIZE; ix++) { + /* what is a mod LBL_prime_tab[ix] */ + if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) { + return err; + } + + /* is the residue zero? */ + if (res == 0) { + *result = MP_YES; + return MP_OKAY; + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_divisible.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_prime_is_prime.c b/rts/ltm/bn_mp_prime_is_prime.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_prime_is_prime.c @@ -0,0 +1,83 @@ +#include +#ifdef BN_MP_PRIME_IS_PRIME_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* performs a variable number of rounds of Miller-Rabin + * + * Probability of error after t rounds is no more than + + * + * Sets result to 1 if probably prime, 0 otherwise + */ +int mp_prime_is_prime (mp_int * a, int t, int *result) +{ + mp_int b; + int ix, err, res; + + /* default to no */ + *result = MP_NO; + + /* valid value of t? */ + if (t <= 0 || t > PRIME_SIZE) { + return MP_VAL; + } + + /* is the input equal to one of the primes in the table? */ + for (ix = 0; ix < PRIME_SIZE; ix++) { + if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) { + *result = 1; + return MP_OKAY; + } + } + + /* first perform trial division */ + if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) { + return err; + } + + /* return if it was trivially divisible */ + if (res == MP_YES) { + return MP_OKAY; + } + + /* now perform the miller-rabin rounds */ + if ((err = mp_init (&b)) != MP_OKAY) { + return err; + } + + for (ix = 0; ix < t; ix++) { + /* set the prime */ + mp_set (&b, ltm_prime_tab[ix]); + + if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) { + goto LBL_B; + } + + if (res == MP_NO) { + goto LBL_B; + } + } + + /* passed the test */ + *result = MP_YES; +LBL_B:mp_clear (&b); + return err; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_is_prime.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_prime_miller_rabin.c b/rts/ltm/bn_mp_prime_miller_rabin.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_prime_miller_rabin.c @@ -0,0 +1,103 @@ +#include +#ifdef BN_MP_PRIME_MILLER_RABIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Miller-Rabin test of "a" to the base of "b" as described in + * HAC pp. 139 Algorithm 4.24 + * + * Sets result to 0 if definitely composite or 1 if probably prime. + * Randomly the chance of error is no more than 1/4 and often + * very much lower. + */ +int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) +{ + mp_int n1, y, r; + int s, j, err; + + /* default */ + *result = MP_NO; + + /* ensure b > 1 */ + if (mp_cmp_d(b, 1) != MP_GT) { + return MP_VAL; + } + + /* get n1 = a - 1 */ + if ((err = mp_init_copy (&n1, a)) != MP_OKAY) { + return err; + } + if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) { + goto LBL_N1; + } + + /* set 2**s * r = n1 */ + if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) { + goto LBL_N1; + } + + /* count the number of least significant bits + * which are zero + */ + s = mp_cnt_lsb(&r); + + /* now divide n - 1 by 2**s */ + if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) { + goto LBL_R; + } + + /* compute y = b**r mod a */ + if ((err = mp_init (&y)) != MP_OKAY) { + goto LBL_R; + } + if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) { + goto LBL_Y; + } + + /* if y != 1 and y != n1 do */ + if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) { + j = 1; + /* while j <= s-1 and y != n1 */ + while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) { + if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) { + goto LBL_Y; + } + + /* if y == 1 then composite */ + if (mp_cmp_d (&y, 1) == MP_EQ) { + goto LBL_Y; + } + + ++j; + } + + /* if y != n1 then composite */ + if (mp_cmp (&y, &n1) != MP_EQ) { + goto LBL_Y; + } + } + + /* probably prime now */ + *result = MP_YES; +LBL_Y:mp_clear (&y); +LBL_R:mp_clear (&r); +LBL_N1:mp_clear (&n1); + return err; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_miller_rabin.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_prime_next_prime.c b/rts/ltm/bn_mp_prime_next_prime.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_prime_next_prime.c @@ -0,0 +1,170 @@ +#include +#ifdef BN_MP_PRIME_NEXT_PRIME_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* finds the next prime after the number "a" using "t" trials + * of Miller-Rabin. + * + * bbs_style = 1 means the prime must be congruent to 3 mod 4 + */ +int mp_prime_next_prime(mp_int *a, int t, int bbs_style) +{ + int err, res, x, y; + mp_digit res_tab[PRIME_SIZE], step, kstep; + mp_int b; + + /* ensure t is valid */ + if (t <= 0 || t > PRIME_SIZE) { + return MP_VAL; + } + + /* force positive */ + a->sign = MP_ZPOS; + + /* simple algo if a is less than the largest prime in the table */ + if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) { + /* find which prime it is bigger than */ + for (x = PRIME_SIZE - 2; x >= 0; x--) { + if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) { + if (bbs_style == 1) { + /* ok we found a prime smaller or + * equal [so the next is larger] + * + * however, the prime must be + * congruent to 3 mod 4 + */ + if ((ltm_prime_tab[x + 1] & 3) != 3) { + /* scan upwards for a prime congruent to 3 mod 4 */ + for (y = x + 1; y < PRIME_SIZE; y++) { + if ((ltm_prime_tab[y] & 3) == 3) { + mp_set(a, ltm_prime_tab[y]); + return MP_OKAY; + } + } + } + } else { + mp_set(a, ltm_prime_tab[x + 1]); + return MP_OKAY; + } + } + } + /* at this point a maybe 1 */ + if (mp_cmp_d(a, 1) == MP_EQ) { + mp_set(a, 2); + return MP_OKAY; + } + /* fall through to the sieve */ + } + + /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ + if (bbs_style == 1) { + kstep = 4; + } else { + kstep = 2; + } + + /* at this point we will use a combination of a sieve and Miller-Rabin */ + + if (bbs_style == 1) { + /* if a mod 4 != 3 subtract the correct value to make it so */ + if ((a->dp[0] & 3) != 3) { + if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; }; + } + } else { + if (mp_iseven(a) == 1) { + /* force odd */ + if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { + return err; + } + } + } + + /* generate the restable */ + for (x = 1; x < PRIME_SIZE; x++) { + if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) { + return err; + } + } + + /* init temp used for Miller-Rabin Testing */ + if ((err = mp_init(&b)) != MP_OKAY) { + return err; + } + + for (;;) { + /* skip to the next non-trivially divisible candidate */ + step = 0; + do { + /* y == 1 if any residue was zero [e.g. cannot be prime] */ + y = 0; + + /* increase step to next candidate */ + step += kstep; + + /* compute the new residue without using division */ + for (x = 1; x < PRIME_SIZE; x++) { + /* add the step to each residue */ + res_tab[x] += kstep; + + /* subtract the modulus [instead of using division] */ + if (res_tab[x] >= ltm_prime_tab[x]) { + res_tab[x] -= ltm_prime_tab[x]; + } + + /* set flag if zero */ + if (res_tab[x] == 0) { + y = 1; + } + } + } while (y == 1 && step < ((((mp_digit)1)<= ((((mp_digit)1)< +#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + + +static const struct { + int k, t; +} sizes[] = { +{ 128, 28 }, +{ 256, 16 }, +{ 384, 10 }, +{ 512, 7 }, +{ 640, 6 }, +{ 768, 5 }, +{ 896, 4 }, +{ 1024, 4 } +}; + +/* returns # of RM trials required for a given bit size */ +int mp_prime_rabin_miller_trials(int size) +{ + int x; + + for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) { + if (sizes[x].k == size) { + return sizes[x].t; + } else if (sizes[x].k > size) { + return (x == 0) ? sizes[0].t : sizes[x - 1].t; + } + } + return sizes[x-1].t + 1; +} + + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_prime_random_ex.c b/rts/ltm/bn_mp_prime_random_ex.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_prime_random_ex.c @@ -0,0 +1,125 @@ +#include +#ifdef BN_MP_PRIME_RANDOM_EX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * LTM_PRIME_BBS - make prime congruent to 3 mod 4 + * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) + * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero + * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ + +/* This is possibly the mother of all prime generation functions, muahahahahaha! */ +int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat) +{ + unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; + int res, err, bsize, maskOR_msb_offset; + + /* sanity check the input */ + if (size <= 1 || t <= 0) { + return MP_VAL; + } + + /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */ + if (flags & LTM_PRIME_SAFE) { + flags |= LTM_PRIME_BBS; + } + + /* calc the byte size */ + bsize = (size>>3) + ((size&7)?1:0); + + /* we need a buffer of bsize bytes */ + tmp = OPT_CAST(unsigned char) XMALLOC(bsize); + if (tmp == NULL) { + return MP_MEM; + } + + /* calc the maskAND value for the MSbyte*/ + maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); + + /* calc the maskOR_msb */ + maskOR_msb = 0; + maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; + if (flags & LTM_PRIME_2MSB_ON) { + maskOR_msb |= 0x80 >> ((9 - size) & 7); + } + + /* get the maskOR_lsb */ + maskOR_lsb = 1; + if (flags & LTM_PRIME_BBS) { + maskOR_lsb |= 3; + } + + do { + /* read the bytes */ + if (cb(tmp, bsize, dat) != bsize) { + err = MP_VAL; + goto error; + } + + /* work over the MSbyte */ + tmp[0] &= maskAND; + tmp[0] |= 1 << ((size - 1) & 7); + + /* mix in the maskORs */ + tmp[maskOR_msb_offset] |= maskOR_msb; + tmp[bsize-1] |= maskOR_lsb; + + /* read it in */ + if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { goto error; } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } + if (res == MP_NO) { + continue; + } + + if (flags & LTM_PRIME_SAFE) { + /* see if (a-1)/2 is prime */ + if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { goto error; } + if ((err = mp_div_2(a, a)) != MP_OKAY) { goto error; } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } + } + } while (res == MP_NO); + + if (flags & LTM_PRIME_SAFE) { + /* restore a to the original value */ + if ((err = mp_mul_2(a, a)) != MP_OKAY) { goto error; } + if ((err = mp_add_d(a, 1, a)) != MP_OKAY) { goto error; } + } + + err = MP_OKAY; +error: + XFREE(tmp); + return err; +} + + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_prime_random_ex.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_radix_size.c b/rts/ltm/bn_mp_radix_size.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_radix_size.c @@ -0,0 +1,78 @@ +#include +#ifdef BN_MP_RADIX_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* returns size of ASCII reprensentation */ +int mp_radix_size (mp_int * a, int radix, int *size) +{ + int res, digs; + mp_int t; + mp_digit d; + + *size = 0; + + /* special case for binary */ + if (radix == 2) { + *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1; + return MP_OKAY; + } + + /* make sure the radix is in range */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + if (mp_iszero(a) == MP_YES) { + *size = 2; + return MP_OKAY; + } + + /* digs is the digit count */ + digs = 0; + + /* if it's negative add one for the sign */ + if (a->sign == MP_NEG) { + ++digs; + } + + /* init a copy of the input */ + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* force temp to positive */ + t.sign = MP_ZPOS; + + /* fetch out all of the digits */ + while (mp_iszero (&t) == MP_NO) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + ++digs; + } + mp_clear (&t); + + /* return digs + 1, the 1 is for the NULL byte that would be required. */ + *size = digs + 1; + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_radix_size.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_radix_smap.c b/rts/ltm/bn_mp_radix_smap.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_radix_smap.c @@ -0,0 +1,24 @@ +#include +#ifdef BN_MP_RADIX_SMAP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* chars used in radix conversions */ +const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_radix_smap.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_rand.c b/rts/ltm/bn_mp_rand.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_rand.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_RAND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* makes a pseudo-random int of a given size */ +int +mp_rand (mp_int * a, int digits) +{ + int res; + mp_digit d; + + mp_zero (a); + if (digits <= 0) { + return MP_OKAY; + } + + /* first place a random non-zero digit */ + do { + d = ((mp_digit) abs (rand ())) & MP_MASK; + } while (d == 0); + + if ((res = mp_add_d (a, d, a)) != MP_OKAY) { + return res; + } + + while (--digits > 0) { + if ((res = mp_lshd (a, 1)) != MP_OKAY) { + return res; + } + + if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) { + return res; + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_rand.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_read_radix.c b/rts/ltm/bn_mp_read_radix.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_read_radix.c @@ -0,0 +1,85 @@ +#include +#ifdef BN_MP_READ_RADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* read a string [ASCII] in a given radix */ +int mp_read_radix (mp_int * a, const char *str, int radix) +{ + int y, res, neg; + char ch; + + /* zero the digit bignum */ + mp_zero(a); + + /* make sure the radix is ok */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + /* if the leading digit is a + * minus set the sign to negative. + */ + if (*str == '-') { + ++str; + neg = MP_NEG; + } else { + neg = MP_ZPOS; + } + + /* set the integer to the default of zero */ + mp_zero (a); + + /* process each digit of the string */ + while (*str) { + /* if the radix < 36 the conversion is case insensitive + * this allows numbers like 1AB and 1ab to represent the same value + * [e.g. in hex] + */ + ch = (char) ((radix < 36) ? toupper (*str) : *str); + for (y = 0; y < 64; y++) { + if (ch == mp_s_rmap[y]) { + break; + } + } + + /* if the char was found in the map + * and is less than the given radix add it + * to the number, otherwise exit the loop. + */ + if (y < radix) { + if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) { + return res; + } + if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) { + return res; + } + } else { + break; + } + ++str; + } + + /* set the sign only if a != 0 */ + if (mp_iszero(a) != 1) { + a->sign = neg; + } + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_read_radix.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_read_signed_bin.c b/rts/ltm/bn_mp_read_signed_bin.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_read_signed_bin.c @@ -0,0 +1,41 @@ +#include +#ifdef BN_MP_READ_SIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* read signed bin, big endian, first byte is 0==positive or 1==negative */ +int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) +{ + int res; + + /* read magnitude */ + if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) { + return res; + } + + /* first byte is 0 for positive, non-zero for negative */ + if (b[0] == 0) { + a->sign = MP_ZPOS; + } else { + a->sign = MP_NEG; + } + + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_read_signed_bin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_read_unsigned_bin.c b/rts/ltm/bn_mp_read_unsigned_bin.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_read_unsigned_bin.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_READ_UNSIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* reads a unsigned char array, assumes the msb is stored first [big endian] */ +int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) +{ + int res; + + /* make sure there are at least two digits */ + if (a->alloc < 2) { + if ((res = mp_grow(a, 2)) != MP_OKAY) { + return res; + } + } + + /* zero the int */ + mp_zero (a); + + /* read the bytes in */ + while (c-- > 0) { + if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) { + return res; + } + +#ifndef MP_8BIT + a->dp[0] |= *b++; + a->used += 1; +#else + a->dp[0] = (*b & MP_MASK); + a->dp[1] |= ((*b++ >> 7U) & 1); + a->used += 2; +#endif + } + mp_clamp (a); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_read_unsigned_bin.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce.c b/rts/ltm/bn_mp_reduce.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce.c @@ -0,0 +1,100 @@ +#include +#ifdef BN_MP_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* reduces x mod m, assumes 0 < x < m**2, mu is + * precomputed via mp_reduce_setup. + * From HAC pp.604 Algorithm 14.42 + */ +int mp_reduce (mp_int * x, mp_int * m, mp_int * mu) +{ + mp_int q; + int res, um = m->used; + + /* q = x */ + if ((res = mp_init_copy (&q, x)) != MP_OKAY) { + return res; + } + + /* q1 = x / b**(k-1) */ + mp_rshd (&q, um - 1); + + /* according to HAC this optimization is ok */ + if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) { + if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) { + goto CLEANUP; + } + } else { +#ifdef BN_S_MP_MUL_HIGH_DIGS_C + if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } +#elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) + if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } +#else + { + res = MP_VAL; + goto CLEANUP; + } +#endif + } + + /* q3 = q2 / b**(k+1) */ + mp_rshd (&q, um + 1); + + /* x = x mod b**(k+1), quick (no division) */ + if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) { + goto CLEANUP; + } + + /* q = q * m mod b**(k+1), quick (no division) */ + if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) { + goto CLEANUP; + } + + /* x = x - q */ + if ((res = mp_sub (x, &q, x)) != MP_OKAY) { + goto CLEANUP; + } + + /* If x < 0, add b**(k+1) to it */ + if (mp_cmp_d (x, 0) == MP_LT) { + mp_set (&q, 1); + if ((res = mp_lshd (&q, um + 1)) != MP_OKAY) + goto CLEANUP; + if ((res = mp_add (x, &q, x)) != MP_OKAY) + goto CLEANUP; + } + + /* Back off if it's too big */ + while (mp_cmp (x, m) != MP_LT) { + if ((res = s_mp_sub (x, m, x)) != MP_OKAY) { + goto CLEANUP; + } + } + +CLEANUP: + mp_clear (&q); + + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_2k.c b/rts/ltm/bn_mp_reduce_2k.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_2k.c @@ -0,0 +1,61 @@ +#include +#ifdef BN_MP_REDUCE_2K_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* reduces a modulo n where n is of the form 2**p - d */ +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d) +{ + mp_int q; + int p, res; + + if ((res = mp_init(&q)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(n); +top: + /* q = a/2**p, a = a mod 2**p */ + if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (d != 1) { + /* q = q * d */ + if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { + goto ERR; + } + } + + /* a = a + q */ + if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (mp_cmp_mag(a, n) != MP_LT) { + s_mp_sub(a, n, a); + goto top; + } + +ERR: + mp_clear(&q); + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_2k_l.c b/rts/ltm/bn_mp_reduce_2k_l.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_2k_l.c @@ -0,0 +1,62 @@ +#include +#ifdef BN_MP_REDUCE_2K_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* reduces a modulo n where n is of the form 2**p - d + This differs from reduce_2k since "d" can be larger + than a single digit. +*/ +int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d) +{ + mp_int q; + int p, res; + + if ((res = mp_init(&q)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(n); +top: + /* q = a/2**p, a = a mod 2**p */ + if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + goto ERR; + } + + /* q = q * d */ + if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { + goto ERR; + } + + /* a = a + q */ + if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (mp_cmp_mag(a, n) != MP_LT) { + s_mp_sub(a, n, a); + goto top; + } + +ERR: + mp_clear(&q); + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_l.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_2k_setup.c b/rts/ltm/bn_mp_reduce_2k_setup.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_2k_setup.c @@ -0,0 +1,47 @@ +#include +#ifdef BN_MP_REDUCE_2K_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines the setup value */ +int mp_reduce_2k_setup(mp_int *a, mp_digit *d) +{ + int res, p; + mp_int tmp; + + if ((res = mp_init(&tmp)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(a); + if ((res = mp_2expt(&tmp, p)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + *d = tmp.dp[0]; + mp_clear(&tmp); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_2k_setup_l.c b/rts/ltm/bn_mp_reduce_2k_setup_l.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_2k_setup_l.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_REDUCE_2K_SETUP_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines the setup value */ +int mp_reduce_2k_setup_l(mp_int *a, mp_int *d) +{ + int res; + mp_int tmp; + + if ((res = mp_init(&tmp)) != MP_OKAY) { + return res; + } + + if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { + goto ERR; + } + + if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear(&tmp); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_is_2k.c b/rts/ltm/bn_mp_reduce_is_2k.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_is_2k.c @@ -0,0 +1,52 @@ +#include +#ifdef BN_MP_REDUCE_IS_2K_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines if mp_reduce_2k can be used */ +int mp_reduce_is_2k(mp_int *a) +{ + int ix, iy, iw; + mp_digit iz; + + if (a->used == 0) { + return MP_NO; + } else if (a->used == 1) { + return MP_YES; + } else if (a->used > 1) { + iy = mp_count_bits(a); + iz = 1; + iw = 1; + + /* Test every bit from the second digit up, must be 1 */ + for (ix = DIGIT_BIT; ix < iy; ix++) { + if ((a->dp[iw] & iz) == 0) { + return MP_NO; + } + iz <<= 1; + if (iz > (mp_digit)MP_MASK) { + ++iw; + iz = 1; + } + } + } + return MP_YES; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_is_2k_l.c b/rts/ltm/bn_mp_reduce_is_2k_l.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_is_2k_l.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_REDUCE_IS_2K_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* determines if reduce_2k_l can be used */ +int mp_reduce_is_2k_l(mp_int *a) +{ + int ix, iy; + + if (a->used == 0) { + return MP_NO; + } else if (a->used == 1) { + return MP_YES; + } else if (a->used > 1) { + /* if more than half of the digits are -1 we're sold */ + for (iy = ix = 0; ix < a->used; ix++) { + if (a->dp[ix] == MP_MASK) { + ++iy; + } + } + return (iy >= (a->used/2)) ? MP_YES : MP_NO; + + } + return MP_NO; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_reduce_setup.c b/rts/ltm/bn_mp_reduce_setup.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_reduce_setup.c @@ -0,0 +1,34 @@ +#include +#ifdef BN_MP_REDUCE_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* pre-calculate the value required for Barrett reduction + * For a given modulus "b" it calulates the value required in "a" + */ +int mp_reduce_setup (mp_int * a, mp_int * b) +{ + int res; + + if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) { + return res; + } + return mp_div (a, b, a, NULL); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_reduce_setup.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_rshd.c b/rts/ltm/bn_mp_rshd.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_rshd.c @@ -0,0 +1,72 @@ +#include +#ifdef BN_MP_RSHD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* shift right a certain amount of digits */ +void mp_rshd (mp_int * a, int b) +{ + int x; + + /* if b <= 0 then ignore it */ + if (b <= 0) { + return; + } + + /* if b > used then simply zero it and return */ + if (a->used <= b) { + mp_zero (a); + return; + } + + { + register mp_digit *bottom, *top; + + /* shift the digits down */ + + /* bottom */ + bottom = a->dp; + + /* top [offset into digits] */ + top = a->dp + b; + + /* this is implemented as a sliding window where + * the window is b-digits long and digits from + * the top of the window are copied to the bottom + * + * e.g. + + b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> + /\ | ----> + \-------------------/ ----> + */ + for (x = 0; x < (a->used - b); x++) { + *bottom++ = *top++; + } + + /* zero the top digits */ + for (; x < a->used; x++) { + *bottom++ = 0; + } + } + + /* remove excess digits */ + a->used -= b; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_rshd.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_set.c b/rts/ltm/bn_mp_set.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_set.c @@ -0,0 +1,29 @@ +#include +#ifdef BN_MP_SET_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* set to a digit */ +void mp_set (mp_int * a, mp_digit b) +{ + mp_zero (a); + a->dp[0] = b & MP_MASK; + a->used = (a->dp[0] != 0) ? 1 : 0; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_set.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_set_int.c b/rts/ltm/bn_mp_set_int.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_set_int.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_SET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* set a 32-bit const */ +int mp_set_int (mp_int * a, unsigned long b) +{ + int x, res; + + mp_zero (a); + + /* set four bits at a time */ + for (x = 0; x < 8; x++) { + /* shift the number up four bits */ + if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { + return res; + } + + /* OR in the top four bits of the source */ + a->dp[0] |= (b >> 28) & 15; + + /* shift the source up to the next four bits */ + b <<= 4; + + /* ensure that digits are not clamped off */ + a->used += 1; + } + mp_clamp (a); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_set_int.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_shrink.c b/rts/ltm/bn_mp_shrink.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_shrink.c @@ -0,0 +1,35 @@ +#include +#ifdef BN_MP_SHRINK_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* shrink a bignum */ +int mp_shrink (mp_int * a) +{ + mp_digit *tmp; + if (a->alloc != a->used && a->used > 0) { + if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { + return MP_MEM; + } + a->dp = tmp; + a->alloc = a->used; + } + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_shrink.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_signed_bin_size.c b/rts/ltm/bn_mp_signed_bin_size.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_signed_bin_size.c @@ -0,0 +1,27 @@ +#include +#ifdef BN_MP_SIGNED_BIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* get the size for an signed equivalent */ +int mp_signed_bin_size (mp_int * a) +{ + return 1 + mp_unsigned_bin_size (a); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_signed_bin_size.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_sqr.c b/rts/ltm/bn_mp_sqr.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_sqr.c @@ -0,0 +1,58 @@ +#include +#ifdef BN_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* computes b = a*a */ +int +mp_sqr (mp_int * a, mp_int * b) +{ + int res; + +#ifdef BN_MP_TOOM_SQR_C + /* use Toom-Cook? */ + if (a->used >= TOOM_SQR_CUTOFF) { + res = mp_toom_sqr(a, b); + /* Karatsuba? */ + } else +#endif +#ifdef BN_MP_KARATSUBA_SQR_C +if (a->used >= KARATSUBA_SQR_CUTOFF) { + res = mp_karatsuba_sqr (a, b); + } else +#endif + { +#ifdef BN_FAST_S_MP_SQR_C + /* can we use the fast comba multiplier? */ + if ((a->used * 2 + 1) < MP_WARRAY && + a->used < + (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) { + res = fast_s_mp_sqr (a, b); + } else +#endif +#ifdef BN_S_MP_SQR_C + res = s_mp_sqr (a, b); +#else + res = MP_VAL; +#endif + } + b->sign = MP_ZPOS; + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_sqr.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_sqrmod.c b/rts/ltm/bn_mp_sqrmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_sqrmod.c @@ -0,0 +1,41 @@ +#include +#ifdef BN_MP_SQRMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* c = a * a (mod b) */ +int +mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_sqr (a, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, b, c); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_sqrmod.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_sqrt.c b/rts/ltm/bn_mp_sqrt.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_sqrt.c @@ -0,0 +1,81 @@ +#include +#ifdef BN_MP_SQRT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* this function is less generic than mp_n_root, simpler and faster */ +int mp_sqrt(mp_int *arg, mp_int *ret) +{ + int res; + mp_int t1,t2; + + /* must be positive */ + if (arg->sign == MP_NEG) { + return MP_VAL; + } + + /* easy out */ + if (mp_iszero(arg) == MP_YES) { + mp_zero(ret); + return MP_OKAY; + } + + if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { + return res; + } + + if ((res = mp_init(&t2)) != MP_OKAY) { + goto E2; + } + + /* First approx. (not very bad for large arg) */ + mp_rshd (&t1,t1.used/2); + + /* t1 > 0 */ + if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { + goto E1; + } + if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { + goto E1; + } + if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { + goto E1; + } + /* And now t1 > sqrt(arg) */ + do { + if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { + goto E1; + } + if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { + goto E1; + } + if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { + goto E1; + } + /* t1 >= sqrt(arg) >= t2 at this point */ + } while (mp_cmp_mag(&t1,&t2) == MP_GT); + + mp_exch(&t1,ret); + +E1: mp_clear(&t2); +E2: mp_clear(&t1); + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_sqrt.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_sub.c b/rts/ltm/bn_mp_sub.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_sub.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_SUB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* high level subtraction (handles signs) */ +int +mp_sub (mp_int * a, mp_int * b, mp_int * c) +{ + int sa, sb, res; + + sa = a->sign; + sb = b->sign; + + if (sa != sb) { + /* subtract a negative from a positive, OR */ + /* subtract a positive from a negative. */ + /* In either case, ADD their magnitudes, */ + /* and use the sign of the first number. */ + c->sign = sa; + res = s_mp_add (a, b, c); + } else { + /* subtract a positive from a positive, OR */ + /* subtract a negative from a negative. */ + /* First, take the difference between their */ + /* magnitudes, then... */ + if (mp_cmp_mag (a, b) != MP_LT) { + /* Copy the sign from the first */ + c->sign = sa; + /* The first has a larger or equal magnitude */ + res = s_mp_sub (a, b, c); + } else { + /* The result has the *opposite* sign from */ + /* the first number. */ + c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; + /* The second has a larger magnitude */ + res = s_mp_sub (b, a, c); + } + } + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_sub.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_sub_d.c b/rts/ltm/bn_mp_sub_d.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_sub_d.c @@ -0,0 +1,93 @@ +#include +#ifdef BN_MP_SUB_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* single digit subtraction */ +int +mp_sub_d (mp_int * a, mp_digit b, mp_int * c) +{ + mp_digit *tmpa, *tmpc, mu; + int res, ix, oldused; + + /* grow c as required */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* if a is negative just do an unsigned + * addition [with fudged signs] + */ + if (a->sign == MP_NEG) { + a->sign = MP_ZPOS; + res = mp_add_d(a, b, c); + a->sign = c->sign = MP_NEG; + + /* clamp */ + mp_clamp(c); + + return res; + } + + /* setup regs */ + oldused = c->used; + tmpa = a->dp; + tmpc = c->dp; + + /* if a <= b simply fix the single digit */ + if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) { + if (a->used == 1) { + *tmpc++ = b - *tmpa; + } else { + *tmpc++ = b; + } + ix = 1; + + /* negative/1digit */ + c->sign = MP_NEG; + c->used = 1; + } else { + /* positive/size */ + c->sign = MP_ZPOS; + c->used = a->used; + + /* subtract first digit */ + *tmpc = *tmpa++ - b; + mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); + *tmpc++ &= MP_MASK; + + /* handle rest of the digits */ + for (ix = 1; ix < a->used; ix++) { + *tmpc = *tmpa++ - mu; + mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); + *tmpc++ &= MP_MASK; + } + } + + /* zero excess digits */ + while (ix++ < oldused) { + *tmpc++ = 0; + } + mp_clamp(c); + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_sub_d.c,v $ */ +/* $Revision: 1.5 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_submod.c b/rts/ltm/bn_mp_submod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_submod.c @@ -0,0 +1,42 @@ +#include +#ifdef BN_MP_SUBMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* d = a - b (mod c) */ +int +mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_sub (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_submod.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_to_signed_bin.c b/rts/ltm/bn_mp_to_signed_bin.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_to_signed_bin.c @@ -0,0 +1,33 @@ +#include +#ifdef BN_MP_TO_SIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* store in signed [big endian] format */ +int mp_to_signed_bin (mp_int * a, unsigned char *b) +{ + int res; + + if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) { + return res; + } + b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_to_signed_bin_n.c b/rts/ltm/bn_mp_to_signed_bin_n.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_to_signed_bin_n.c @@ -0,0 +1,31 @@ +#include +#ifdef BN_MP_TO_SIGNED_BIN_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* store in signed [big endian] format */ +int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) +{ + if (*outlen < (unsigned long)mp_signed_bin_size(a)) { + return MP_VAL; + } + *outlen = mp_signed_bin_size(a); + return mp_to_signed_bin(a, b); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_to_signed_bin_n.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_to_unsigned_bin.c b/rts/ltm/bn_mp_to_unsigned_bin.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_to_unsigned_bin.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_TO_UNSIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* store in unsigned [big endian] format */ +int mp_to_unsigned_bin (mp_int * a, unsigned char *b) +{ + int x, res; + mp_int t; + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + x = 0; + while (mp_iszero (&t) == 0) { +#ifndef MP_8BIT + b[x++] = (unsigned char) (t.dp[0] & 255); +#else + b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7)); +#endif + if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) { + mp_clear (&t); + return res; + } + } + bn_reverse (b, x); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_to_unsigned_bin_n.c b/rts/ltm/bn_mp_to_unsigned_bin_n.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_to_unsigned_bin_n.c @@ -0,0 +1,31 @@ +#include +#ifdef BN_MP_TO_UNSIGNED_BIN_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* store in unsigned [big endian] format */ +int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) +{ + if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { + return MP_VAL; + } + *outlen = mp_unsigned_bin_size(a); + return mp_to_unsigned_bin(a, b); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_toom_mul.c b/rts/ltm/bn_mp_toom_mul.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_toom_mul.c @@ -0,0 +1,284 @@ +#include +#ifdef BN_MP_TOOM_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* multiplication using the Toom-Cook 3-way algorithm + * + * Much more complicated than Karatsuba but has a lower + * asymptotic running time of O(N**1.464). This algorithm is + * only particularly useful on VERY large inputs + * (we're talking 1000s of digits here...). +*/ +int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) +{ + mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2; + int res, B; + + /* init temps */ + if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, + &a0, &a1, &a2, &b0, &b1, + &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) { + return res; + } + + /* B */ + B = MIN(a->used, b->used) / 3; + + /* a = a2 * B**2 + a1 * B + a0 */ + if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(a, &a1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a1, B); + mp_mod_2d(&a1, DIGIT_BIT * B, &a1); + + if ((res = mp_copy(a, &a2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a2, B*2); + + /* b = b2 * B**2 + b1 * B + b0 */ + if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(b, &b1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&b1, B); + mp_mod_2d(&b1, DIGIT_BIT * B, &b1); + + if ((res = mp_copy(b, &b2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&b2, B*2); + + /* w0 = a0*b0 */ + if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) { + goto ERR; + } + + /* w4 = a2 * b2 */ + if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) { + goto ERR; + } + + /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ + if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) { + goto ERR; + } + + /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ + if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) { + goto ERR; + } + + + /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ + if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) { + goto ERR; + } + + /* now solve the matrix + + 0 0 0 0 1 + 1 2 4 8 16 + 1 1 1 1 1 + 16 8 4 2 1 + 1 0 0 0 0 + + using 12 subtractions, 4 shifts, + 2 small divisions and 1 small multiplication + */ + + /* r1 - r4 */ + if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r0 */ + if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/2 */ + if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3/2 */ + if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { + goto ERR; + } + /* r2 - r0 - r4 */ + if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1 - 8r0 */ + if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - 8r4 */ + if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + /* 3r2 - r1 - r3 */ + if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/3 */ + if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { + goto ERR; + } + /* r3/3 */ + if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { + goto ERR; + } + + /* at this point shift W[n] by B*n */ + if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear_multi(&w0, &w1, &w2, &w3, &w4, + &a0, &a1, &a2, &b0, &b1, + &b2, &tmp1, &tmp2, NULL); + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_toom_mul.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_toom_sqr.c b/rts/ltm/bn_mp_toom_sqr.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_toom_sqr.c @@ -0,0 +1,226 @@ +#include +#ifdef BN_MP_TOOM_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* squaring using Toom-Cook 3-way algorithm */ +int +mp_toom_sqr(mp_int *a, mp_int *b) +{ + mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2; + int res, B; + + /* init temps */ + if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) { + return res; + } + + /* B */ + B = a->used / 3; + + /* a = a2 * B**2 + a1 * B + a0 */ + if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(a, &a1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a1, B); + mp_mod_2d(&a1, DIGIT_BIT * B, &a1); + + if ((res = mp_copy(a, &a2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a2, B*2); + + /* w0 = a0*a0 */ + if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) { + goto ERR; + } + + /* w4 = a2 * a2 */ + if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) { + goto ERR; + } + + /* w1 = (a2 + 2(a1 + 2a0))**2 */ + if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + + /* w3 = (a0 + 2(a1 + 2a2))**2 */ + if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + + + /* w2 = (a2 + a1 + a0)**2 */ + if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) { + goto ERR; + } + + /* now solve the matrix + + 0 0 0 0 1 + 1 2 4 8 16 + 1 1 1 1 1 + 16 8 4 2 1 + 1 0 0 0 0 + + using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication. + */ + + /* r1 - r4 */ + if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r0 */ + if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/2 */ + if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3/2 */ + if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { + goto ERR; + } + /* r2 - r0 - r4 */ + if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1 - 8r0 */ + if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - 8r4 */ + if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + /* 3r2 - r1 - r3 */ + if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/3 */ + if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { + goto ERR; + } + /* r3/3 */ + if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { + goto ERR; + } + + /* at this point shift W[n] by B*n */ + if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL); + return res; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_toom_sqr.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_toradix.c b/rts/ltm/bn_mp_toradix.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_toradix.c @@ -0,0 +1,75 @@ +#include +#ifdef BN_MP_TORADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* stores a bignum as a ASCII string in a given radix (2..64) */ +int mp_toradix (mp_int * a, char *str, int radix) +{ + int res, digs; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of the radix */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + /* quick out if its zero */ + if (mp_iszero(a) == 1) { + *str++ = '0'; + *str = '\0'; + return MP_OKAY; + } + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + ++_s; + *str++ = '-'; + t.sign = MP_ZPOS; + } + + digs = 0; + while (mp_iszero (&t) == 0) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + *str++ = mp_s_rmap[d]; + ++digs; + } + + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number] + */ + bn_reverse ((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + + mp_clear (&t); + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_toradix.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_toradix_n.c b/rts/ltm/bn_mp_toradix_n.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_toradix_n.c @@ -0,0 +1,88 @@ +#include +#ifdef BN_MP_TORADIX_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* stores a bignum as a ASCII string in a given radix (2..64) + * + * Stores upto maxlen-1 chars and always a NULL byte + */ +int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) +{ + int res, digs; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of the maxlen, radix */ + if (maxlen < 2 || radix < 2 || radix > 64) { + return MP_VAL; + } + + /* quick out if its zero */ + if (mp_iszero(a) == MP_YES) { + *str++ = '0'; + *str = '\0'; + return MP_OKAY; + } + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + /* we have to reverse our digits later... but not the - sign!! */ + ++_s; + + /* store the flag and mark the number as positive */ + *str++ = '-'; + t.sign = MP_ZPOS; + + /* subtract a char */ + --maxlen; + } + + digs = 0; + while (mp_iszero (&t) == 0) { + if (--maxlen < 1) { + /* no more room */ + break; + } + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + *str++ = mp_s_rmap[d]; + ++digs; + } + + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number + */ + bn_reverse ((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + + mp_clear (&t); + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_toradix_n.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_unsigned_bin_size.c b/rts/ltm/bn_mp_unsigned_bin_size.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_unsigned_bin_size.c @@ -0,0 +1,28 @@ +#include +#ifdef BN_MP_UNSIGNED_BIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* get the size for an unsigned equivalent */ +int mp_unsigned_bin_size (mp_int * a) +{ + int size = mp_count_bits (a); + return (size / 8 + ((size & 7) != 0 ? 1 : 0)); +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_unsigned_bin_size.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_xor.c b/rts/ltm/bn_mp_xor.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_xor.c @@ -0,0 +1,51 @@ +#include +#ifdef BN_MP_XOR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* XOR two ints together */ +int +mp_xor (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] ^= x->dp[ix]; + } + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_xor.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_mp_zero.c b/rts/ltm/bn_mp_zero.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_mp_zero.c @@ -0,0 +1,36 @@ +#include +#ifdef BN_MP_ZERO_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* set to zero */ +void mp_zero (mp_int * a) +{ + int n; + mp_digit *tmp; + + a->sign = MP_ZPOS; + a->used = 0; + + tmp = a->dp; + for (n = 0; n < a->alloc; n++) { + *tmp++ = 0; + } +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_mp_zero.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_prime_tab.c b/rts/ltm/bn_prime_tab.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_prime_tab.c @@ -0,0 +1,61 @@ +#include +#ifdef BN_PRIME_TAB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ +const mp_digit ltm_prime_tab[] = { + 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, + 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, + 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, + 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, +#ifndef MP_8BIT + 0x0083, + 0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD, + 0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF, + 0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107, + 0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137, + + 0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167, + 0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199, + 0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9, + 0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7, + 0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239, + 0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265, + 0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293, + 0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF, + + 0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301, + 0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B, + 0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371, + 0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD, + 0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5, + 0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419, + 0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449, + 0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B, + + 0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7, + 0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503, + 0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529, + 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, + 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, + 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, + 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, + 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 +#endif +}; +#endif + +/* $Source: /cvs/libtom/libtommath/bn_prime_tab.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_reverse.c b/rts/ltm/bn_reverse.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_reverse.c @@ -0,0 +1,39 @@ +#include +#ifdef BN_REVERSE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* reverse an array, used for radix code */ +void +bn_reverse (unsigned char *s, int len) +{ + int ix, iy; + unsigned char t; + + ix = 0; + iy = len - 1; + while (ix < iy) { + t = s[ix]; + s[ix] = s[iy]; + s[iy] = t; + ++ix; + --iy; + } +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_reverse.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_s_mp_add.c b/rts/ltm/bn_s_mp_add.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_s_mp_add.c @@ -0,0 +1,109 @@ +#include +#ifdef BN_S_MP_ADD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* low level addition, based on HAC pp.594, Algorithm 14.7 */ +int +s_mp_add (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int *x; + int olduse, res, min, max; + + /* find sizes, we let |a| <= |b| which means we have to sort + * them. "x" will point to the input with the most digits + */ + if (a->used > b->used) { + min = b->used; + max = a->used; + x = a; + } else { + min = a->used; + max = b->used; + x = b; + } + + /* init result */ + if (c->alloc < max + 1) { + if ((res = mp_grow (c, max + 1)) != MP_OKAY) { + return res; + } + } + + /* get old used digit count and set new one */ + olduse = c->used; + c->used = max + 1; + + { + register mp_digit u, *tmpa, *tmpb, *tmpc; + register int i; + + /* alias for digit pointers */ + + /* first input */ + tmpa = a->dp; + + /* second input */ + tmpb = b->dp; + + /* destination */ + tmpc = c->dp; + + /* zero the carry */ + u = 0; + for (i = 0; i < min; i++) { + /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ + *tmpc = *tmpa++ + *tmpb++ + u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)DIGIT_BIT); + + /* take away carry bit from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* now copy higher words if any, that is in A+B + * if A or B has more digits add those in + */ + if (min != max) { + for (; i < max; i++) { + /* T[i] = X[i] + U */ + *tmpc = x->dp[i] + u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)DIGIT_BIT); + + /* take away carry bit from T[i] */ + *tmpc++ &= MP_MASK; + } + } + + /* add carry */ + *tmpc++ = u; + + /* clear digits above oldused */ + for (i = c->used; i < olduse; i++) { + *tmpc++ = 0; + } + } + + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_s_mp_add.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_s_mp_exptmod.c b/rts/ltm/bn_s_mp_exptmod.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_s_mp_exptmod.c @@ -0,0 +1,252 @@ +#include +#ifdef BN_S_MP_EXPTMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ +#ifdef MP_LOW_MEM + #define TAB_SIZE 32 +#else + #define TAB_SIZE 256 +#endif + +int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) +{ + mp_int M[TAB_SIZE], res, mu; + mp_digit buf; + int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + int (*redux)(mp_int*,mp_int*,mp_int*); + + /* find window size */ + x = mp_count_bits (X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + +#ifdef MP_LOW_MEM + if (winsize > 5) { + winsize = 5; + } +#endif + + /* init M array */ + /* init first cell */ + if ((err = mp_init(&M[1])) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init(&M[x])) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear (&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* create mu, used for Barrett reduction */ + if ((err = mp_init (&mu)) != MP_OKAY) { + goto LBL_M; + } + + if (redmode == 0) { + if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) { + goto LBL_MU; + } + redux = mp_reduce; + } else { + if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + redux = mp_reduce_2k_l; + } + + /* create M table + * + * The M table contains powers of the base, + * e.g. M[x] = G**x mod P + * + * The first half of the table is not + * computed though accept for M[0] and M[1] + */ + if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) { + goto LBL_MU; + } + + /* compute the value at M[1<<(winsize-1)] by squaring + * M[1] (winsize-1) times + */ + if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_MU; + } + + for (x = 0; x < (winsize - 1); x++) { + /* square it */ + if ((err = mp_sqr (&M[1 << (winsize - 1)], + &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_MU; + } + + /* reduce modulo P */ + if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) + * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) + */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { + goto LBL_MU; + } + if ((err = redux (&M[x], P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* setup result */ + if ((err = mp_init (&res)) != MP_OKAY) { + goto LBL_MU; + } + mp_set (&res, 1); + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits */ + if (digidx == -1) { + break; + } + /* read next digit and reset the bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int) DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if (mode == 0 && y == 0) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if (mode == 1 && y == 0) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* then multiply */ + if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if (mode == 2 && bitcpy > 0) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + } + } + } + + mp_exch (&res, Y); + err = MP_OKAY; +LBL_RES:mp_clear (&res); +LBL_MU:mp_clear (&mu); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear (&M[x]); + } + return err; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_s_mp_exptmod.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_s_mp_mul_digs.c b/rts/ltm/bn_s_mp_mul_digs.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_s_mp_mul_digs.c @@ -0,0 +1,90 @@ +#include +#ifdef BN_S_MP_MUL_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* multiplies |a| * |b| and only computes upto digs digits of result + * HAC pp. 595, Algorithm 14.12 Modified so you can control how + * many digits of output are created. + */ +int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + mp_int t; + int res, pa, pb, ix, iy; + mp_digit u; + mp_word r; + mp_digit tmpx, *tmpt, *tmpy; + + /* can we use the fast multiplier? */ + if (((digs) < MP_WARRAY) && + MIN (a->used, b->used) < + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_s_mp_mul_digs (a, b, c, digs); + } + + if ((res = mp_init_size (&t, digs)) != MP_OKAY) { + return res; + } + t.used = digs; + + /* compute the digits of the product directly */ + pa = a->used; + for (ix = 0; ix < pa; ix++) { + /* set the carry to zero */ + u = 0; + + /* limit ourselves to making digs digits of output */ + pb = MIN (b->used, digs - ix); + + /* setup some aliases */ + /* copy of the digit from a used within the nested loop */ + tmpx = a->dp[ix]; + + /* an alias for the destination shifted ix places */ + tmpt = t.dp + ix; + + /* an alias for the digits of b */ + tmpy = b->dp; + + /* compute the columns of the output and propagate the carry */ + for (iy = 0; iy < pb; iy++) { + /* compute the column as a mp_word */ + r = ((mp_word)*tmpt) + + ((mp_word)tmpx) * ((mp_word)*tmpy++) + + ((mp_word) u); + + /* the new column is the lower part of the result */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get the carry word from the result */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + /* set carry if it is placed below digs */ + if (ix + iy < digs) { + *tmpt = u; + } + } + + mp_clamp (&t); + mp_exch (&t, c); + + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_s_mp_mul_high_digs.c b/rts/ltm/bn_s_mp_mul_high_digs.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_s_mp_mul_high_digs.c @@ -0,0 +1,81 @@ +#include +#ifdef BN_S_MP_MUL_HIGH_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* multiplies |a| * |b| and does not compute the lower digs digits + * [meant to get the higher part of the product] + */ +int +s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + mp_int t; + int res, pa, pb, ix, iy; + mp_digit u; + mp_word r; + mp_digit tmpx, *tmpt, *tmpy; + + /* can we use the fast multiplier? */ +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C + if (((a->used + b->used + 1) < MP_WARRAY) + && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_s_mp_mul_high_digs (a, b, c, digs); + } +#endif + + if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) { + return res; + } + t.used = a->used + b->used + 1; + + pa = a->used; + pb = b->used; + for (ix = 0; ix < pa; ix++) { + /* clear the carry */ + u = 0; + + /* left hand side of A[ix] * B[iy] */ + tmpx = a->dp[ix]; + + /* alias to the address of where the digits will be stored */ + tmpt = &(t.dp[digs]); + + /* alias for where to read the right hand side from */ + tmpy = b->dp + (digs - ix); + + for (iy = digs - ix; iy < pb; iy++) { + /* calculate the double precision result */ + r = ((mp_word)*tmpt) + + ((mp_word)tmpx) * ((mp_word)*tmpy++) + + ((mp_word) u); + + /* get the lower part */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* carry the carry */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + *tmpt = u; + } + mp_clamp (&t); + mp_exch (&t, c); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_s_mp_sqr.c b/rts/ltm/bn_s_mp_sqr.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_s_mp_sqr.c @@ -0,0 +1,84 @@ +#include +#ifdef BN_S_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ +int s_mp_sqr (mp_int * a, mp_int * b) +{ + mp_int t; + int res, ix, iy, pa; + mp_word r; + mp_digit u, tmpx, *tmpt; + + pa = a->used; + if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) { + return res; + } + + /* default used is maximum possible size */ + t.used = 2*pa + 1; + + for (ix = 0; ix < pa; ix++) { + /* first calculate the digit at 2*ix */ + /* calculate double precision result */ + r = ((mp_word) t.dp[2*ix]) + + ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]); + + /* store lower part in result */ + t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get the carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + + /* left hand side of A[ix] * A[iy] */ + tmpx = a->dp[ix]; + + /* alias for where to store the results */ + tmpt = t.dp + (2*ix + 1); + + for (iy = ix + 1; iy < pa; iy++) { + /* first calculate the product */ + r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]); + + /* now calculate the double precision result, note we use + * addition instead of *2 since it's easier to optimize + */ + r = ((mp_word) *tmpt) + r + r + ((mp_word) u); + + /* store lower part */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + } + /* propagate upwards */ + while (u != ((mp_digit) 0)) { + r = ((mp_word) *tmpt) + ((mp_word) u); + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + } + } + + mp_clamp (&t); + mp_exch (&t, b); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /cvs/libtom/libtommath/bn_s_mp_sqr.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bn_s_mp_sub.c b/rts/ltm/bn_s_mp_sub.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bn_s_mp_sub.c @@ -0,0 +1,89 @@ +#include +#ifdef BN_S_MP_SUB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ +int +s_mp_sub (mp_int * a, mp_int * b, mp_int * c) +{ + int olduse, res, min, max; + + /* find sizes */ + min = b->used; + max = a->used; + + /* init result */ + if (c->alloc < max) { + if ((res = mp_grow (c, max)) != MP_OKAY) { + return res; + } + } + olduse = c->used; + c->used = max; + + { + register mp_digit u, *tmpa, *tmpb, *tmpc; + register int i; + + /* alias for digit pointers */ + tmpa = a->dp; + tmpb = b->dp; + tmpc = c->dp; + + /* set carry to zero */ + u = 0; + for (i = 0; i < min; i++) { + /* T[i] = A[i] - B[i] - U */ + *tmpc = *tmpa++ - *tmpb++ - u; + + /* U = carry bit of T[i] + * Note this saves performing an AND operation since + * if a carry does occur it will propagate all the way to the + * MSB. As a result a single shift is enough to get the carry + */ + u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); + + /* Clear carry from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* now copy higher words if any, e.g. if A has more digits than B */ + for (; i < max; i++) { + /* T[i] = A[i] - U */ + *tmpc = *tmpa++ - u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); + + /* Clear carry from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* clear digits above used (since we may not have grown result above) */ + for (i = c->used; i < olduse; i++) { + *tmpc++ = 0; + } + } + + mp_clamp (c); + return MP_OKAY; +} + +#endif + +/* $Source: /cvs/libtom/libtommath/bn_s_mp_sub.c,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/bncore.c b/rts/ltm/bncore.c new file mode 100644 --- /dev/null +++ b/rts/ltm/bncore.c @@ -0,0 +1,36 @@ +#include +#ifdef BNCORE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ + +/* Known optimal configurations + + CPU /Compiler /MUL CUTOFF/SQR CUTOFF +------------------------------------------------------------- + Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) + AMD Athlon64 /GCC v3.4.4 / 80/ 120/LTM 0.35 + +*/ + +int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsuba multiplication is used. */ + KARATSUBA_SQR_CUTOFF = 120, /* Min. number of digits before Karatsuba squaring is used. */ + + TOOM_MUL_CUTOFF = 350, /* no optimal values of these are known yet so set em high */ + TOOM_SQR_CUTOFF = 400; +#endif + +/* $Source: /cvs/libtom/libtommath/bncore.c,v $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/tommath.h b/rts/ltm/tommath.h new file mode 100644 --- /dev/null +++ b/rts/ltm/tommath.h @@ -0,0 +1,584 @@ +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + */ +#ifndef BN_H_ +#define BN_H_ + +#include +#include +#include +#include +#include + +#include + +#ifndef MIN + #define MIN(x,y) ((x)<(y)?(x):(y)) +#endif + +#ifndef MAX + #define MAX(x,y) ((x)>(y)?(x):(y)) +#endif + +#ifdef __cplusplus +extern "C" { + +/* C++ compilers don't like assigning void * to mp_digit * */ +#define OPT_CAST(x) (x *) + +#else + +/* C on the other hand doesn't care */ +#define OPT_CAST(x) + +#endif + + +/* detect 64-bit mode if possible */ +#if defined(__x86_64__) + #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) + #define MP_64BIT + #endif +#endif + +/* some default configurations. + * + * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits + * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits + * + * At the very least a mp_digit must be able to hold 7 bits + * [any size beyond that is ok provided it doesn't overflow the data type] + */ +#ifdef MP_8BIT + typedef unsigned char mp_digit; + typedef unsigned short mp_word; +#elif defined(MP_16BIT) + typedef unsigned short mp_digit; + typedef unsigned long mp_word; +#elif defined(MP_64BIT) + /* for GCC only on supported platforms */ +#ifndef CRYPT + typedef unsigned long long ulong64; + typedef signed long long long64; +#endif + + typedef unsigned long mp_digit; + typedef unsigned long mp_word __attribute__ ((mode(TI))); + + #define DIGIT_BIT 60 +#else + /* this is the default case, 28-bit digits */ + + /* this is to make porting into LibTomCrypt easier :-) */ +#ifndef CRYPT + #if defined(_MSC_VER) || defined(__BORLANDC__) + typedef unsigned __int64 ulong64; + typedef signed __int64 long64; + #else + typedef unsigned long long ulong64; + typedef signed long long long64; + #endif +#endif + + typedef unsigned long mp_digit; + typedef ulong64 mp_word; + +#ifdef MP_31BIT + /* this is an extension that uses 31-bit digits */ + #define DIGIT_BIT 31 +#else + /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ + #define DIGIT_BIT 28 + #define MP_28BIT +#endif +#endif + +/* define heap macros */ +#ifndef CRYPT + /* default to libc stuff */ + #ifndef XMALLOC + #define XMALLOC malloc + #define XFREE free + #define XREALLOC realloc + #define XCALLOC calloc + #else + /* prototypes for our heap functions */ + extern void *XMALLOC(size_t n); + extern void *XREALLOC(void *p, size_t n); + extern void *XCALLOC(size_t n, size_t s); + extern void XFREE(void *p); + #endif +#endif + + +/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ +#ifndef DIGIT_BIT + #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ +#endif + +#define MP_DIGIT_BIT DIGIT_BIT +#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) +#define MP_DIGIT_MAX MP_MASK + +/* equalities */ +#define MP_LT -1 /* less than */ +#define MP_EQ 0 /* equal to */ +#define MP_GT 1 /* greater than */ + +#define MP_ZPOS 0 /* positive integer */ +#define MP_NEG 1 /* negative */ + +#define MP_OKAY 0 /* ok result */ +#define MP_MEM -2 /* out of mem */ +#define MP_VAL -3 /* invalid input */ +#define MP_RANGE MP_VAL + +#define MP_YES 1 /* yes response */ +#define MP_NO 0 /* no response */ + +/* Primality generation flags */ +#define LTM_PRIME_BBS 0x0001 /* BBS style prime */ +#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ +#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ + +typedef int mp_err; + +/* you'll have to tune these... */ +extern int KARATSUBA_MUL_CUTOFF, + KARATSUBA_SQR_CUTOFF, + TOOM_MUL_CUTOFF, + TOOM_SQR_CUTOFF; + +/* define this to use lower memory usage routines (exptmods mostly) */ +/* #define MP_LOW_MEM */ + +/* default precision */ +#ifndef MP_PREC + #ifndef MP_LOW_MEM + #define MP_PREC 32 /* default digits of precision */ + #else + #define MP_PREC 8 /* default digits of precision */ + #endif +#endif + +/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ +#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) + +/* the infamous mp_int structure */ +typedef struct { + int used, alloc, sign; + mp_digit *dp; +} mp_int; + +/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ +typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); + + +#define USED(m) ((m)->used) +#define DIGIT(m,k) ((m)->dp[(k)]) +#define SIGN(m) ((m)->sign) + +/* error code to char* string */ +char *mp_error_to_string(int code); + +/* ---> init and deinit bignum functions <--- */ +/* init a bignum */ +int mp_init(mp_int *a); + +/* free a bignum */ +void mp_clear(mp_int *a); + +/* init a null terminated series of arguments */ +int mp_init_multi(mp_int *mp, ...); + +/* clear a null terminated series of arguments */ +void mp_clear_multi(mp_int *mp, ...); + +/* exchange two ints */ +void mp_exch(mp_int *a, mp_int *b); + +/* shrink ram required for a bignum */ +int mp_shrink(mp_int *a); + +/* grow an int to a given size */ +int mp_grow(mp_int *a, int size); + +/* init to a given number of digits */ +int mp_init_size(mp_int *a, int size); + +/* ---> Basic Manipulations <--- */ +#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) +#define mp_iseven(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) +#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) + +/* set to zero */ +void mp_zero(mp_int *a); + +/* set to a digit */ +void mp_set(mp_int *a, mp_digit b); + +/* set a 32-bit const */ +int mp_set_int(mp_int *a, unsigned long b); + +/* get a 32-bit value */ +unsigned long mp_get_int(mp_int * a); + +/* initialize and set a digit */ +int mp_init_set (mp_int * a, mp_digit b); + +/* initialize and set 32-bit value */ +int mp_init_set_int (mp_int * a, unsigned long b); + +/* copy, b = a */ +int mp_copy(mp_int *a, mp_int *b); + +/* inits and copies, a = b */ +int mp_init_copy(mp_int *a, mp_int *b); + +/* trim unused digits */ +void mp_clamp(mp_int *a); + +/* ---> digit manipulation <--- */ + +/* right shift by "b" digits */ +void mp_rshd(mp_int *a, int b); + +/* left shift by "b" digits */ +int mp_lshd(mp_int *a, int b); + +/* c = a / 2**b */ +int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d); + +/* b = a/2 */ +int mp_div_2(mp_int *a, mp_int *b); + +/* c = a * 2**b */ +int mp_mul_2d(mp_int *a, int b, mp_int *c); + +/* b = a*2 */ +int mp_mul_2(mp_int *a, mp_int *b); + +/* c = a mod 2**d */ +int mp_mod_2d(mp_int *a, int b, mp_int *c); + +/* computes a = 2**b */ +int mp_2expt(mp_int *a, int b); + +/* Counts the number of lsbs which are zero before the first zero bit */ +int mp_cnt_lsb(mp_int *a); + +/* I Love Earth! */ + +/* makes a pseudo-random int of a given size */ +int mp_rand(mp_int *a, int digits); + +/* ---> binary operations <--- */ +/* c = a XOR b */ +int mp_xor(mp_int *a, mp_int *b, mp_int *c); + +/* c = a OR b */ +int mp_or(mp_int *a, mp_int *b, mp_int *c); + +/* c = a AND b */ +int mp_and(mp_int *a, mp_int *b, mp_int *c); + +/* ---> Basic arithmetic <--- */ + +/* b = -a */ +int mp_neg(mp_int *a, mp_int *b); + +/* b = |a| */ +int mp_abs(mp_int *a, mp_int *b); + +/* compare a to b */ +int mp_cmp(mp_int *a, mp_int *b); + +/* compare |a| to |b| */ +int mp_cmp_mag(mp_int *a, mp_int *b); + +/* c = a + b */ +int mp_add(mp_int *a, mp_int *b, mp_int *c); + +/* c = a - b */ +int mp_sub(mp_int *a, mp_int *b, mp_int *c); + +/* c = a * b */ +int mp_mul(mp_int *a, mp_int *b, mp_int *c); + +/* b = a*a */ +int mp_sqr(mp_int *a, mp_int *b); + +/* a/b => cb + d == a */ +int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* c = a mod b, 0 <= c < b */ +int mp_mod(mp_int *a, mp_int *b, mp_int *c); + +/* ---> single digit functions <--- */ + +/* compare against a single digit */ +int mp_cmp_d(mp_int *a, mp_digit b); + +/* c = a + b */ +int mp_add_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a - b */ +int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a * b */ +int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); + +/* a/b => cb + d == a */ +int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); + +/* a/3 => 3c + d == a */ +int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); + +/* c = a**b */ +int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a mod b, 0 <= c < b */ +int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); + +/* ---> number theory <--- */ + +/* d = a + b (mod c) */ +int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* d = a - b (mod c) */ +int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* d = a * b (mod c) */ +int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* c = a * a (mod b) */ +int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); + +/* c = 1/a (mod b) */ +int mp_invmod(mp_int *a, mp_int *b, mp_int *c); + +/* c = (a, b) */ +int mp_gcd(mp_int *a, mp_int *b, mp_int *c); + +/* produces value such that U1*a + U2*b = U3 */ +int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); + +/* c = [a, b] or (a*b)/(a, b) */ +int mp_lcm(mp_int *a, mp_int *b, mp_int *c); + +/* finds one of the b'th root of a, such that |c|**b <= |a| + * + * returns error if a < 0 and b is even + */ +int mp_n_root(mp_int *a, mp_digit b, mp_int *c); + +/* special sqrt algo */ +int mp_sqrt(mp_int *arg, mp_int *ret); + +/* is number a square? */ +int mp_is_square(mp_int *arg, int *ret); + +/* computes the jacobi c = (a | n) (or Legendre if b is prime) */ +int mp_jacobi(mp_int *a, mp_int *n, int *c); + +/* used to setup the Barrett reduction for a given modulus b */ +int mp_reduce_setup(mp_int *a, mp_int *b); + +/* Barrett Reduction, computes a (mod b) with a precomputed value c + * + * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely + * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. + */ +int mp_reduce(mp_int *a, mp_int *b, mp_int *c); + +/* setups the montgomery reduction */ +int mp_montgomery_setup(mp_int *a, mp_digit *mp); + +/* computes a = B**n mod b without division or multiplication useful for + * normalizing numbers in a Montgomery system. + */ +int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); + +/* computes x/R == x (mod N) via Montgomery Reduction */ +int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); + +/* returns 1 if a is a valid DR modulus */ +int mp_dr_is_modulus(mp_int *a); + +/* sets the value of "d" required for mp_dr_reduce */ +void mp_dr_setup(mp_int *a, mp_digit *d); + +/* reduces a modulo b using the Diminished Radix method */ +int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); + +/* returns true if a can be reduced with mp_reduce_2k */ +int mp_reduce_is_2k(mp_int *a); + +/* determines k value for 2k reduction */ +int mp_reduce_2k_setup(mp_int *a, mp_digit *d); + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); + +/* returns true if a can be reduced with mp_reduce_2k_l */ +int mp_reduce_is_2k_l(mp_int *a); + +/* determines k value for 2k reduction */ +int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); + +/* d = a**b (mod c) */ +int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* ---> Primes <--- */ + +/* number of primes */ +#ifdef MP_8BIT + #define PRIME_SIZE 31 +#else + #define PRIME_SIZE 256 +#endif + +/* table of first PRIME_SIZE primes */ +extern const mp_digit ltm_prime_tab[]; + +/* result=1 if a is divisible by one of the first PRIME_SIZE primes */ +int mp_prime_is_divisible(mp_int *a, int *result); + +/* performs one Fermat test of "a" using base "b". + * Sets result to 0 if composite or 1 if probable prime + */ +int mp_prime_fermat(mp_int *a, mp_int *b, int *result); + +/* performs one Miller-Rabin test of "a" using base "b". + * Sets result to 0 if composite or 1 if probable prime + */ +int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); + +/* This gives [for a given bit size] the number of trials required + * such that Miller-Rabin gives a prob of failure lower than 2^-96 + */ +int mp_prime_rabin_miller_trials(int size); + +/* performs t rounds of Miller-Rabin on "a" using the first + * t prime bases. Also performs an initial sieve of trial + * division. Determines if "a" is prime with probability + * of error no more than (1/4)**t. + * + * Sets result to 1 if probably prime, 0 otherwise + */ +int mp_prime_is_prime(mp_int *a, int t, int *result); + +/* finds the next prime after the number "a" using "t" trials + * of Miller-Rabin. + * + * bbs_style = 1 means the prime must be congruent to 3 mod 4 + */ +int mp_prime_next_prime(mp_int *a, int t, int bbs_style); + +/* makes a truly random prime of a given size (bytes), + * call with bbs = 1 if you want it to be congruent to 3 mod 4 + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + * The prime generated will be larger than 2^(8*size). + */ +#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * LTM_PRIME_BBS - make prime congruent to 3 mod 4 + * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) + * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero + * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ +int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); + +/* ---> radix conversion <--- */ +int mp_count_bits(mp_int *a); + +int mp_unsigned_bin_size(mp_int *a); +int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); +int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); + +int mp_signed_bin_size(mp_int *a); +int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); +int mp_to_signed_bin(mp_int *a, unsigned char *b); +int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); + +int mp_read_radix(mp_int *a, const char *str, int radix); +int mp_toradix(mp_int *a, char *str, int radix); +int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); +int mp_radix_size(mp_int *a, int radix, int *size); + +int mp_fread(mp_int *a, int radix, FILE *stream); +int mp_fwrite(mp_int *a, int radix, FILE *stream); + +#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) +#define mp_raw_size(mp) mp_signed_bin_size(mp) +#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) +#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) mp_unsigned_bin_size(mp) +#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) + +#define mp_tobinary(M, S) mp_toradix((M), (S), 2) +#define mp_tooctal(M, S) mp_toradix((M), (S), 8) +#define mp_todecimal(M, S) mp_toradix((M), (S), 10) +#define mp_tohex(M, S) mp_toradix((M), (S), 16) + +/* lowlevel functions, do not call! */ +int s_mp_add(mp_int *a, mp_int *b, mp_int *c); +int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) +int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int fast_s_mp_sqr(mp_int *a, mp_int *b); +int s_mp_sqr(mp_int *a, mp_int *b); +int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); +int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +int mp_karatsuba_sqr(mp_int *a, mp_int *b); +int mp_toom_sqr(mp_int *a, mp_int *b); +int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); +int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); +int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); +int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); +void bn_reverse(unsigned char *s, int len); + +extern const char *mp_s_rmap; + +#ifdef __cplusplus + } +#endif + +#endif + + +/* $Source: /cvs/libtom/libtommath/tommath.h,v $ */ +/* $Revision: 1.8 $ */ +/* $Date: 2006/03/31 14:18:44 $ */ diff --git a/rts/ltm/tommath_class.h b/rts/ltm/tommath_class.h new file mode 100644 --- /dev/null +++ b/rts/ltm/tommath_class.h @@ -0,0 +1,999 @@ +#if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) +#if defined(LTM2) +#define LTM3 +#endif +#if defined(LTM1) +#define LTM2 +#endif +#define LTM1 + +#if defined(LTM_ALL) +#define BN_ERROR_C +#define BN_FAST_MP_INVMOD_C +#define BN_FAST_MP_MONTGOMERY_REDUCE_C +#define BN_FAST_S_MP_MUL_DIGS_C +#define BN_FAST_S_MP_MUL_HIGH_DIGS_C +#define BN_FAST_S_MP_SQR_C +#define BN_MP_2EXPT_C +#define BN_MP_ABS_C +#define BN_MP_ADD_C +#define BN_MP_ADD_D_C +#define BN_MP_ADDMOD_C +#define BN_MP_AND_C +#define BN_MP_CLAMP_C +#define BN_MP_CLEAR_C +#define BN_MP_CLEAR_MULTI_C +#define BN_MP_CMP_C +#define BN_MP_CMP_D_C +#define BN_MP_CMP_MAG_C +#define BN_MP_CNT_LSB_C +#define BN_MP_COPY_C +#define BN_MP_COUNT_BITS_C +#define BN_MP_DIV_C +#define BN_MP_DIV_2_C +#define BN_MP_DIV_2D_C +#define BN_MP_DIV_3_C +#define BN_MP_DIV_D_C +#define BN_MP_DR_IS_MODULUS_C +#define BN_MP_DR_REDUCE_C +#define BN_MP_DR_SETUP_C +#define BN_MP_EXCH_C +#define BN_MP_EXPT_D_C +#define BN_MP_EXPTMOD_C +#define BN_MP_EXPTMOD_FAST_C +#define BN_MP_EXTEUCLID_C +#define BN_MP_FREAD_C +#define BN_MP_FWRITE_C +#define BN_MP_GCD_C +#define BN_MP_GET_INT_C +#define BN_MP_GROW_C +#define BN_MP_INIT_C +#define BN_MP_INIT_COPY_C +#define BN_MP_INIT_MULTI_C +#define BN_MP_INIT_SET_C +#define BN_MP_INIT_SET_INT_C +#define BN_MP_INIT_SIZE_C +#define BN_MP_INVMOD_C +#define BN_MP_INVMOD_SLOW_C +#define BN_MP_IS_SQUARE_C +#define BN_MP_JACOBI_C +#define BN_MP_KARATSUBA_MUL_C +#define BN_MP_KARATSUBA_SQR_C +#define BN_MP_LCM_C +#define BN_MP_LSHD_C +#define BN_MP_MOD_C +#define BN_MP_MOD_2D_C +#define BN_MP_MOD_D_C +#define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +#define BN_MP_MONTGOMERY_REDUCE_C +#define BN_MP_MONTGOMERY_SETUP_C +#define BN_MP_MUL_C +#define BN_MP_MUL_2_C +#define BN_MP_MUL_2D_C +#define BN_MP_MUL_D_C +#define BN_MP_MULMOD_C +#define BN_MP_N_ROOT_C +#define BN_MP_NEG_C +#define BN_MP_OR_C +#define BN_MP_PRIME_FERMAT_C +#define BN_MP_PRIME_IS_DIVISIBLE_C +#define BN_MP_PRIME_IS_PRIME_C +#define BN_MP_PRIME_MILLER_RABIN_C +#define BN_MP_PRIME_NEXT_PRIME_C +#define BN_MP_PRIME_RABIN_MILLER_TRIALS_C +#define BN_MP_PRIME_RANDOM_EX_C +#define BN_MP_RADIX_SIZE_C +#define BN_MP_RADIX_SMAP_C +#define BN_MP_RAND_C +#define BN_MP_READ_RADIX_C +#define BN_MP_READ_SIGNED_BIN_C +#define BN_MP_READ_UNSIGNED_BIN_C +#define BN_MP_REDUCE_C +#define BN_MP_REDUCE_2K_C +#define BN_MP_REDUCE_2K_L_C +#define BN_MP_REDUCE_2K_SETUP_C +#define BN_MP_REDUCE_2K_SETUP_L_C +#define BN_MP_REDUCE_IS_2K_C +#define BN_MP_REDUCE_IS_2K_L_C +#define BN_MP_REDUCE_SETUP_C +#define BN_MP_RSHD_C +#define BN_MP_SET_C +#define BN_MP_SET_INT_C +#define BN_MP_SHRINK_C +#define BN_MP_SIGNED_BIN_SIZE_C +#define BN_MP_SQR_C +#define BN_MP_SQRMOD_C +#define BN_MP_SQRT_C +#define BN_MP_SUB_C +#define BN_MP_SUB_D_C +#define BN_MP_SUBMOD_C +#define BN_MP_TO_SIGNED_BIN_C +#define BN_MP_TO_SIGNED_BIN_N_C +#define BN_MP_TO_UNSIGNED_BIN_C +#define BN_MP_TO_UNSIGNED_BIN_N_C +#define BN_MP_TOOM_MUL_C +#define BN_MP_TOOM_SQR_C +#define BN_MP_TORADIX_C +#define BN_MP_TORADIX_N_C +#define BN_MP_UNSIGNED_BIN_SIZE_C +#define BN_MP_XOR_C +#define BN_MP_ZERO_C +#define BN_PRIME_TAB_C +#define BN_REVERSE_C +#define BN_S_MP_ADD_C +#define BN_S_MP_EXPTMOD_C +#define BN_S_MP_MUL_DIGS_C +#define BN_S_MP_MUL_HIGH_DIGS_C +#define BN_S_MP_SQR_C +#define BN_S_MP_SUB_C +#define BNCORE_C +#endif + +#if defined(BN_ERROR_C) + #define BN_MP_ERROR_TO_STRING_C +#endif + +#if defined(BN_FAST_MP_INVMOD_C) + #define BN_MP_ISEVEN_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_COPY_C + #define BN_MP_MOD_C + #define BN_MP_SET_C + #define BN_MP_DIV_2_C + #define BN_MP_ISODD_C + #define BN_MP_SUB_C + #define BN_MP_CMP_C + #define BN_MP_ISZERO_C + #define BN_MP_CMP_D_C + #define BN_MP_ADD_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_FAST_MP_MONTGOMERY_REDUCE_C) + #define BN_MP_GROW_C + #define BN_MP_RSHD_C + #define BN_MP_CLAMP_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_FAST_S_MP_MUL_DIGS_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_FAST_S_MP_SQR_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_2EXPT_C) + #define BN_MP_ZERO_C + #define BN_MP_GROW_C +#endif + +#if defined(BN_MP_ABS_C) + #define BN_MP_COPY_C +#endif + +#if defined(BN_MP_ADD_C) + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_ADD_D_C) + #define BN_MP_GROW_C + #define BN_MP_SUB_D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_ADDMOD_C) + #define BN_MP_INIT_C + #define BN_MP_ADD_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_AND_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_CLAMP_C) +#endif + +#if defined(BN_MP_CLEAR_C) +#endif + +#if defined(BN_MP_CLEAR_MULTI_C) + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_CMP_C) + #define BN_MP_CMP_MAG_C +#endif + +#if defined(BN_MP_CMP_D_C) +#endif + +#if defined(BN_MP_CMP_MAG_C) +#endif + +#if defined(BN_MP_CNT_LSB_C) + #define BN_MP_ISZERO_C +#endif + +#if defined(BN_MP_COPY_C) + #define BN_MP_GROW_C +#endif + +#if defined(BN_MP_COUNT_BITS_C) +#endif + +#if defined(BN_MP_DIV_C) + #define BN_MP_ISZERO_C + #define BN_MP_CMP_MAG_C + #define BN_MP_COPY_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_SET_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_ABS_C + #define BN_MP_MUL_2D_C + #define BN_MP_CMP_C + #define BN_MP_SUB_C + #define BN_MP_ADD_C + #define BN_MP_DIV_2D_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_INIT_C + #define BN_MP_INIT_COPY_C + #define BN_MP_LSHD_C + #define BN_MP_RSHD_C + #define BN_MP_MUL_D_C + #define BN_MP_CLAMP_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_DIV_2_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_DIV_2D_C) + #define BN_MP_COPY_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_C + #define BN_MP_MOD_2D_C + #define BN_MP_CLEAR_C + #define BN_MP_RSHD_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_MP_DIV_3_C) + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_DIV_D_C) + #define BN_MP_ISZERO_C + #define BN_MP_COPY_C + #define BN_MP_DIV_2D_C + #define BN_MP_DIV_3_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_DR_IS_MODULUS_C) +#endif + +#if defined(BN_MP_DR_REDUCE_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_DR_SETUP_C) +#endif + +#if defined(BN_MP_EXCH_C) +#endif + +#if defined(BN_MP_EXPT_D_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_SET_C + #define BN_MP_SQR_C + #define BN_MP_CLEAR_C + #define BN_MP_MUL_C +#endif + +#if defined(BN_MP_EXPTMOD_C) + #define BN_MP_INIT_C + #define BN_MP_INVMOD_C + #define BN_MP_CLEAR_C + #define BN_MP_ABS_C + #define BN_MP_CLEAR_MULTI_C + #define BN_MP_REDUCE_IS_2K_L_C + #define BN_S_MP_EXPTMOD_C + #define BN_MP_DR_IS_MODULUS_C + #define BN_MP_REDUCE_IS_2K_C + #define BN_MP_ISODD_C + #define BN_MP_EXPTMOD_FAST_C +#endif + +#if defined(BN_MP_EXPTMOD_FAST_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_INIT_C + #define BN_MP_CLEAR_C + #define BN_MP_MONTGOMERY_SETUP_C + #define BN_FAST_MP_MONTGOMERY_REDUCE_C + #define BN_MP_MONTGOMERY_REDUCE_C + #define BN_MP_DR_SETUP_C + #define BN_MP_DR_REDUCE_C + #define BN_MP_REDUCE_2K_SETUP_C + #define BN_MP_REDUCE_2K_C + #define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C + #define BN_MP_MULMOD_C + #define BN_MP_SET_C + #define BN_MP_MOD_C + #define BN_MP_COPY_C + #define BN_MP_SQR_C + #define BN_MP_MUL_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_MP_EXTEUCLID_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_SET_C + #define BN_MP_COPY_C + #define BN_MP_ISZERO_C + #define BN_MP_DIV_C + #define BN_MP_MUL_C + #define BN_MP_SUB_C + #define BN_MP_NEG_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_FREAD_C) + #define BN_MP_ZERO_C + #define BN_MP_S_RMAP_C + #define BN_MP_MUL_D_C + #define BN_MP_ADD_D_C + #define BN_MP_CMP_D_C +#endif + +#if defined(BN_MP_FWRITE_C) + #define BN_MP_RADIX_SIZE_C + #define BN_MP_TORADIX_C +#endif + +#if defined(BN_MP_GCD_C) + #define BN_MP_ISZERO_C + #define BN_MP_ABS_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_CNT_LSB_C + #define BN_MP_DIV_2D_C + #define BN_MP_CMP_MAG_C + #define BN_MP_EXCH_C + #define BN_S_MP_SUB_C + #define BN_MP_MUL_2D_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_GET_INT_C) +#endif + +#if defined(BN_MP_GROW_C) +#endif + +#if defined(BN_MP_INIT_C) +#endif + +#if defined(BN_MP_INIT_COPY_C) + #define BN_MP_COPY_C +#endif + +#if defined(BN_MP_INIT_MULTI_C) + #define BN_MP_ERR_C + #define BN_MP_INIT_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_INIT_SET_C) + #define BN_MP_INIT_C + #define BN_MP_SET_C +#endif + +#if defined(BN_MP_INIT_SET_INT_C) + #define BN_MP_INIT_C + #define BN_MP_SET_INT_C +#endif + +#if defined(BN_MP_INIT_SIZE_C) + #define BN_MP_INIT_C +#endif + +#if defined(BN_MP_INVMOD_C) + #define BN_MP_ISZERO_C + #define BN_MP_ISODD_C + #define BN_FAST_MP_INVMOD_C + #define BN_MP_INVMOD_SLOW_C +#endif + +#if defined(BN_MP_INVMOD_SLOW_C) + #define BN_MP_ISZERO_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_MOD_C + #define BN_MP_COPY_C + #define BN_MP_ISEVEN_C + #define BN_MP_SET_C + #define BN_MP_DIV_2_C + #define BN_MP_ISODD_C + #define BN_MP_ADD_C + #define BN_MP_SUB_C + #define BN_MP_CMP_C + #define BN_MP_CMP_D_C + #define BN_MP_CMP_MAG_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_IS_SQUARE_C) + #define BN_MP_MOD_D_C + #define BN_MP_INIT_SET_INT_C + #define BN_MP_MOD_C + #define BN_MP_GET_INT_C + #define BN_MP_SQRT_C + #define BN_MP_SQR_C + #define BN_MP_CMP_MAG_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_JACOBI_C) + #define BN_MP_CMP_D_C + #define BN_MP_ISZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_CNT_LSB_C + #define BN_MP_DIV_2D_C + #define BN_MP_MOD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_KARATSUBA_MUL_C) + #define BN_MP_MUL_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_SUB_C + #define BN_MP_ADD_C + #define BN_MP_LSHD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_KARATSUBA_SQR_C) + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_SQR_C + #define BN_MP_SUB_C + #define BN_S_MP_ADD_C + #define BN_MP_LSHD_C + #define BN_MP_ADD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_LCM_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_GCD_C + #define BN_MP_CMP_MAG_C + #define BN_MP_DIV_C + #define BN_MP_MUL_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_LSHD_C) + #define BN_MP_GROW_C + #define BN_MP_RSHD_C +#endif + +#if defined(BN_MP_MOD_C) + #define BN_MP_INIT_C + #define BN_MP_DIV_C + #define BN_MP_CLEAR_C + #define BN_MP_ADD_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_MP_MOD_2D_C) + #define BN_MP_ZERO_C + #define BN_MP_COPY_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_MOD_D_C) + #define BN_MP_DIV_D_C +#endif + +#if defined(BN_MP_MONTGOMERY_CALC_NORMALIZATION_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_2EXPT_C + #define BN_MP_SET_C + #define BN_MP_MUL_2_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_MONTGOMERY_REDUCE_C) + #define BN_FAST_MP_MONTGOMERY_REDUCE_C + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C + #define BN_MP_RSHD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_MONTGOMERY_SETUP_C) +#endif + +#if defined(BN_MP_MUL_C) + #define BN_MP_TOOM_MUL_C + #define BN_MP_KARATSUBA_MUL_C + #define BN_FAST_S_MP_MUL_DIGS_C + #define BN_S_MP_MUL_C + #define BN_S_MP_MUL_DIGS_C +#endif + +#if defined(BN_MP_MUL_2_C) + #define BN_MP_GROW_C +#endif + +#if defined(BN_MP_MUL_2D_C) + #define BN_MP_COPY_C + #define BN_MP_GROW_C + #define BN_MP_LSHD_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_MUL_D_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_MULMOD_C) + #define BN_MP_INIT_C + #define BN_MP_MUL_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_N_ROOT_C) + #define BN_MP_INIT_C + #define BN_MP_SET_C + #define BN_MP_COPY_C + #define BN_MP_EXPT_D_C + #define BN_MP_MUL_C + #define BN_MP_SUB_C + #define BN_MP_MUL_D_C + #define BN_MP_DIV_C + #define BN_MP_CMP_C + #define BN_MP_SUB_D_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_NEG_C) + #define BN_MP_COPY_C + #define BN_MP_ISZERO_C +#endif + +#if defined(BN_MP_OR_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_FERMAT_C) + #define BN_MP_CMP_D_C + #define BN_MP_INIT_C + #define BN_MP_EXPTMOD_C + #define BN_MP_CMP_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_IS_DIVISIBLE_C) + #define BN_MP_MOD_D_C +#endif + +#if defined(BN_MP_PRIME_IS_PRIME_C) + #define BN_MP_CMP_D_C + #define BN_MP_PRIME_IS_DIVISIBLE_C + #define BN_MP_INIT_C + #define BN_MP_SET_C + #define BN_MP_PRIME_MILLER_RABIN_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_MILLER_RABIN_C) + #define BN_MP_CMP_D_C + #define BN_MP_INIT_COPY_C + #define BN_MP_SUB_D_C + #define BN_MP_CNT_LSB_C + #define BN_MP_DIV_2D_C + #define BN_MP_EXPTMOD_C + #define BN_MP_CMP_C + #define BN_MP_SQRMOD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_NEXT_PRIME_C) + #define BN_MP_CMP_D_C + #define BN_MP_SET_C + #define BN_MP_SUB_D_C + #define BN_MP_ISEVEN_C + #define BN_MP_MOD_D_C + #define BN_MP_INIT_C + #define BN_MP_ADD_D_C + #define BN_MP_PRIME_MILLER_RABIN_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C) +#endif + +#if defined(BN_MP_PRIME_RANDOM_EX_C) + #define BN_MP_READ_UNSIGNED_BIN_C + #define BN_MP_PRIME_IS_PRIME_C + #define BN_MP_SUB_D_C + #define BN_MP_DIV_2_C + #define BN_MP_MUL_2_C + #define BN_MP_ADD_D_C +#endif + +#if defined(BN_MP_RADIX_SIZE_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_INIT_COPY_C + #define BN_MP_ISZERO_C + #define BN_MP_DIV_D_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_RADIX_SMAP_C) + #define BN_MP_S_RMAP_C +#endif + +#if defined(BN_MP_RAND_C) + #define BN_MP_ZERO_C + #define BN_MP_ADD_D_C + #define BN_MP_LSHD_C +#endif + +#if defined(BN_MP_READ_RADIX_C) + #define BN_MP_ZERO_C + #define BN_MP_S_RMAP_C + #define BN_MP_RADIX_SMAP_C + #define BN_MP_MUL_D_C + #define BN_MP_ADD_D_C + #define BN_MP_ISZERO_C +#endif + +#if defined(BN_MP_READ_SIGNED_BIN_C) + #define BN_MP_READ_UNSIGNED_BIN_C +#endif + +#if defined(BN_MP_READ_UNSIGNED_BIN_C) + #define BN_MP_GROW_C + #define BN_MP_ZERO_C + #define BN_MP_MUL_2D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_REDUCE_C) + #define BN_MP_REDUCE_SETUP_C + #define BN_MP_INIT_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_MUL_C + #define BN_S_MP_MUL_HIGH_DIGS_C + #define BN_FAST_S_MP_MUL_HIGH_DIGS_C + #define BN_MP_MOD_2D_C + #define BN_S_MP_MUL_DIGS_C + #define BN_MP_SUB_C + #define BN_MP_CMP_D_C + #define BN_MP_SET_C + #define BN_MP_LSHD_C + #define BN_MP_ADD_C + #define BN_MP_CMP_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_2K_C) + #define BN_MP_INIT_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_DIV_2D_C + #define BN_MP_MUL_D_C + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_2K_L_C) + #define BN_MP_INIT_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_DIV_2D_C + #define BN_MP_MUL_C + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_2K_SETUP_C) + #define BN_MP_INIT_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_2EXPT_C + #define BN_MP_CLEAR_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_REDUCE_2K_SETUP_L_C) + #define BN_MP_INIT_C + #define BN_MP_2EXPT_C + #define BN_MP_COUNT_BITS_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_IS_2K_C) + #define BN_MP_REDUCE_2K_C + #define BN_MP_COUNT_BITS_C +#endif + +#if defined(BN_MP_REDUCE_IS_2K_L_C) +#endif + +#if defined(BN_MP_REDUCE_SETUP_C) + #define BN_MP_2EXPT_C + #define BN_MP_DIV_C +#endif + +#if defined(BN_MP_RSHD_C) + #define BN_MP_ZERO_C +#endif + +#if defined(BN_MP_SET_C) + #define BN_MP_ZERO_C +#endif + +#if defined(BN_MP_SET_INT_C) + #define BN_MP_ZERO_C + #define BN_MP_MUL_2D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_SHRINK_C) +#endif + +#if defined(BN_MP_SIGNED_BIN_SIZE_C) + #define BN_MP_UNSIGNED_BIN_SIZE_C +#endif + +#if defined(BN_MP_SQR_C) + #define BN_MP_TOOM_SQR_C + #define BN_MP_KARATSUBA_SQR_C + #define BN_FAST_S_MP_SQR_C + #define BN_S_MP_SQR_C +#endif + +#if defined(BN_MP_SQRMOD_C) + #define BN_MP_INIT_C + #define BN_MP_SQR_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_SQRT_C) + #define BN_MP_N_ROOT_C + #define BN_MP_ISZERO_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_DIV_C + #define BN_MP_ADD_C + #define BN_MP_DIV_2_C + #define BN_MP_CMP_MAG_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_SUB_C) + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_SUB_D_C) + #define BN_MP_GROW_C + #define BN_MP_ADD_D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_SUBMOD_C) + #define BN_MP_INIT_C + #define BN_MP_SUB_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_TO_SIGNED_BIN_C) + #define BN_MP_TO_UNSIGNED_BIN_C +#endif + +#if defined(BN_MP_TO_SIGNED_BIN_N_C) + #define BN_MP_SIGNED_BIN_SIZE_C + #define BN_MP_TO_SIGNED_BIN_C +#endif + +#if defined(BN_MP_TO_UNSIGNED_BIN_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_ISZERO_C + #define BN_MP_DIV_2D_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_TO_UNSIGNED_BIN_N_C) + #define BN_MP_UNSIGNED_BIN_SIZE_C + #define BN_MP_TO_UNSIGNED_BIN_C +#endif + +#if defined(BN_MP_TOOM_MUL_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_MOD_2D_C + #define BN_MP_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_MUL_C + #define BN_MP_MUL_2_C + #define BN_MP_ADD_C + #define BN_MP_SUB_C + #define BN_MP_DIV_2_C + #define BN_MP_MUL_2D_C + #define BN_MP_MUL_D_C + #define BN_MP_DIV_3_C + #define BN_MP_LSHD_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_TOOM_SQR_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_MOD_2D_C + #define BN_MP_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_SQR_C + #define BN_MP_MUL_2_C + #define BN_MP_ADD_C + #define BN_MP_SUB_C + #define BN_MP_DIV_2_C + #define BN_MP_MUL_2D_C + #define BN_MP_MUL_D_C + #define BN_MP_DIV_3_C + #define BN_MP_LSHD_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_TORADIX_C) + #define BN_MP_ISZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_DIV_D_C + #define BN_MP_CLEAR_C + #define BN_MP_S_RMAP_C +#endif + +#if defined(BN_MP_TORADIX_N_C) + #define BN_MP_ISZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_DIV_D_C + #define BN_MP_CLEAR_C + #define BN_MP_S_RMAP_C +#endif + +#if defined(BN_MP_UNSIGNED_BIN_SIZE_C) + #define BN_MP_COUNT_BITS_C +#endif + +#if defined(BN_MP_XOR_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_ZERO_C) +#endif + +#if defined(BN_PRIME_TAB_C) +#endif + +#if defined(BN_REVERSE_C) +#endif + +#if defined(BN_S_MP_ADD_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_S_MP_EXPTMOD_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_INIT_C + #define BN_MP_CLEAR_C + #define BN_MP_REDUCE_SETUP_C + #define BN_MP_REDUCE_C + #define BN_MP_REDUCE_2K_SETUP_L_C + #define BN_MP_REDUCE_2K_L_C + #define BN_MP_MOD_C + #define BN_MP_COPY_C + #define BN_MP_SQR_C + #define BN_MP_MUL_C + #define BN_MP_SET_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_S_MP_MUL_DIGS_C) + #define BN_FAST_S_MP_MUL_DIGS_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_S_MP_MUL_HIGH_DIGS_C) + #define BN_FAST_S_MP_MUL_HIGH_DIGS_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_S_MP_SQR_C) + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_S_MP_SUB_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BNCORE_C) +#endif + +#ifdef LTM3 +#define LTM_LAST +#endif +#include +#include +#else +#define LTM_LAST +#endif + +/* $Source: /cvs/libtom/libtommath/tommath_class.h,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2005/07/28 11:59:32 $ */ diff --git a/rts/ltm/tommath_superclass.h b/rts/ltm/tommath_superclass.h new file mode 100644 --- /dev/null +++ b/rts/ltm/tommath_superclass.h @@ -0,0 +1,76 @@ +/* super class file for PK algos */ + +/* default ... include all MPI */ +#define LTM_ALL + +/* RSA only (does not support DH/DSA/ECC) */ +/* #define SC_RSA_1 */ + +/* For reference.... On an Athlon64 optimizing for speed... + + LTM's mpi.o with all functions [striped] is 142KiB in size. + +*/ + +/* Works for RSA only, mpi.o is 68KiB */ +#ifdef SC_RSA_1 + #define BN_MP_SHRINK_C + #define BN_MP_LCM_C + #define BN_MP_PRIME_RANDOM_EX_C + #define BN_MP_INVMOD_C + #define BN_MP_GCD_C + #define BN_MP_MOD_C + #define BN_MP_MULMOD_C + #define BN_MP_ADDMOD_C + #define BN_MP_EXPTMOD_C + #define BN_MP_SET_INT_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_CLEAR_MULTI_C + #define BN_MP_UNSIGNED_BIN_SIZE_C + #define BN_MP_TO_UNSIGNED_BIN_C + #define BN_MP_MOD_D_C + #define BN_MP_PRIME_RABIN_MILLER_TRIALS_C + #define BN_REVERSE_C + #define BN_PRIME_TAB_C + + /* other modifiers */ + #define BN_MP_DIV_SMALL /* Slower division, not critical */ + + /* here we are on the last pass so we turn things off. The functions classes are still there + * but we remove them specifically from the build. This also invokes tweaks in functions + * like removing support for even moduli, etc... + */ +#ifdef LTM_LAST + #undef BN_MP_TOOM_MUL_C + #undef BN_MP_TOOM_SQR_C + #undef BN_MP_KARATSUBA_MUL_C + #undef BN_MP_KARATSUBA_SQR_C + #undef BN_MP_REDUCE_C + #undef BN_MP_REDUCE_SETUP_C + #undef BN_MP_DR_IS_MODULUS_C + #undef BN_MP_DR_SETUP_C + #undef BN_MP_DR_REDUCE_C + #undef BN_MP_REDUCE_IS_2K_C + #undef BN_MP_REDUCE_2K_SETUP_C + #undef BN_MP_REDUCE_2K_C + #undef BN_S_MP_EXPTMOD_C + #undef BN_MP_DIV_3_C + #undef BN_S_MP_MUL_HIGH_DIGS_C + #undef BN_FAST_S_MP_MUL_HIGH_DIGS_C + #undef BN_FAST_MP_INVMOD_C + + /* To safely undefine these you have to make sure your RSA key won't exceed the Comba threshold + * which is roughly 255 digits [7140 bits for 32-bit machines, 15300 bits for 64-bit machines] + * which means roughly speaking you can handle upto 2536-bit RSA keys with these defined without + * trouble. + */ + #undef BN_S_MP_MUL_DIGS_C + #undef BN_S_MP_SQR_C + #undef BN_MP_MONTGOMERY_REDUCE_C +#endif + +#endif + +/* $Source: /cvs/libtom/libtommath/tommath_superclass.h,v $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2005/05/14 13:29:17 $ */ diff --git a/rts/rts.c b/rts/rts.c new file mode 100644 --- /dev/null +++ b/rts/rts.c @@ -0,0 +1,227 @@ +/* Header: */ +#include +#include +#include +#include +#include +#include +#include + +#include "tommath.h" + +typedef unsigned long u64; +typedef unsigned int u32; +typedef unsigned short u16; +typedef unsigned char u8; +typedef signed long s64; +typedef signed int s32; +typedef signed short s16; +typedef signed char s8; + +typedef u64 unit; +typedef s64 sunit; + +int global_argc; +char **global_argv; + +void getProgArgv(int *argc, char ***argv) +{ + *argc = global_argc; + *argv = global_argv; +} + +void panic(char *str) +{ + puts(str); + exit(1); +} + +typedef union { float d; unit *w; } DoubleOrUnit; + +float wordToDouble(unit *x) { + DoubleOrUnit u; + u.w = x; + return u.d; +} +unit *doubleToWord(float x) { + DoubleOrUnit u; + u.d = x; + return u.w; +} + +int __hscore_get_errno(void) +{ + return errno; +} +ssize_t __hscore_PrelHandle_write(int fd, void *ptr, int offset, size_t count) +{ + return write(fd, ptr + offset, count); +} +void *__hscore_memcpy_dst_off(void *dest, int offset, void *src, size_t n) +{ + return memcpy(dest+offset, src, n); +} + +unit *rts_newArray(unit *ptr, unit value, unit size) +{ + unit i; + for(i = 0; i < size; i++) ptr[i] = value; + return ptr; +} + +void show_mp(char *str, mp_int *mp) +{ + char buf[1000]; + printf("%s: ", str); + mp_toradix(mp, buf, 10); + printf("%s\n", buf); +} + +mp_int *lhc_mp_from_int(sunit i) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init_set_int(mp,i); + return mp; +} +int lhc_mp_get_int(mp_int *mp) +{ + return mp_get_int(mp); +} + +mp_int *lhc_mp_mul(mp_int *a, mp_int *b) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_mul(a,b,mp); + return mp; +} +mp_int *lhc_mp_add(mp_int *a, mp_int *b) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_add(a,b,mp); + return mp; +} +mp_int *lhc_mp_sub(mp_int *a, mp_int *b) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_sub(a,b,mp); + return mp; +} +mp_int *lhc_mp_gcd(mp_int *a, mp_int *b) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_gcd(a,b,mp); + return mp; +} +mp_int *lhc_mp_quot(mp_int *a, mp_int *b) +{ + mp_int *mp; + mp_int rem; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_init(&rem); + mp_div(a,b,mp,&rem); + return mp; +} +mp_int *lhc_mp_rem(mp_int *a, mp_int *b) +{ + mp_int *mod; + mod = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mod); + mp_mod(a,b,mod); + return mod; +} +mp_int *lhc_mp_abs(mp_int *a) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_abs(a,mp); + return mp; +} +mp_int *lhc_mp_negate(mp_int *a) +{ + mp_int *mp; + mp = (mp_int*) GC_MALLOC(sizeof(mp_int)); + mp_init(mp); + mp_neg(a,mp); + return mp; +} + +sunit lhc_mp_cmp(mp_int *a, mp_int *b) +{ + return mp_cmp(a,b); +} + +/* +int lhc_mp_cmp(mp_int *a, mp_int *b +foreign import ccall unsafe "lhc_mp_cmp" mp_cmp :: Mp_int -> Mp_int -> Int# +foreign import ccall unsafe "lhc_mp_get_int" mp_get_int :: Mp_int -> Int# + +foreign import ccall unsafe "lhc_mp_from_int" mp_from_int :: Int# -> Mp_int +foreign import ccall unsafe "lhc_mp_mul" mp_mul :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_add" mp_add :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_sub" mp_sub :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_or" mp_or :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_and" mp_and :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_xor" mp_xor :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_gcd" mp_gcd :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_lcm" mp_lcm :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_quot" mp_quot :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_rem" mp_rem :: Mp_int -> Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_abs" mp_abs :: Mp_int -> Mp_int +foreign import ccall unsafe "lhc_mp_negate" mp_negate :: Mp_int -> Mp_int +*/ + +/* +int global; + +int fn(int i) { + switch(i) { + case 0: + { + global=global; + int y=10; + return y; + } + case 1: + return (unit) doubleToWord(10); + default: + return 2; + } +} +*/ + +#define BLOCK_SIZE (4096) +void* alloc(int size) { return GC_MALLOC(size); } + +// Block allocation leads to less total allocations but higher total residency. +// The higher residency makes GCing a lot slower. +/* +void* alloc(int size) +{ + static void *p = NULL, *limit = NULL; + void *t; + int max; + if (p==NULL) { + p = GC_MALLOC(BLOCK_SIZE); + limit = p + BLOCK_SIZE; + } + if (p+size > limit) { + max = BLOCK_SIZE > size ? BLOCK_SIZE : size; + p = GC_MALLOC(max); + limit = p + max; + } + t = p; + p += size; + return t; +} +*/ diff --git a/rts/rts.ll b/rts/rts.ll new file mode 100644 --- /dev/null +++ b/rts/rts.ll @@ -0,0 +1,27 @@ +; LHC RTS: + +%unit = type i32 + +; We return function results in this global array. +%returnArrayT = type [20 x %unit] +@rtsReturnArray = global %returnArrayT zeroinitializer + +define %unit @getReturnValue(i32 %idx) { + %retPtr = getelementptr %returnArrayT* @rtsReturnArray, i32 0, i32 %idx + %val = load %unit* %retPtr + store %unit 0, %unit* %retPtr + ret %unit %val +} + +define %unit* @getReturnValuePtr(i32 %idx) { + %retPtr = getelementptr %returnArrayT* @rtsReturnArray, i32 0, i32 %idx + ret %unit* %retPtr +} + +define void @setReturnValue(i32 %idx, %unit %val) { + %retPtr = call %unit* @getReturnValuePtr(i32 %idx) + store %unit %val, %unit* %retPtr + ret void +} + +; End of LHC RTS. diff --git a/src/GhcMain.hs b/src/GhcMain.hs --- a/src/GhcMain.hs +++ b/src/GhcMain.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} - ------------------------------------------------------------------------------ --- --- GHC Driver program --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - module Main (main) where import Paths_lhc @@ -16,40 +5,7 @@ import System.Info import System.Directory --- The official GHC API -import qualified GHC -import GHC ( DynFlags(..), HscTarget(..), - GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..) ) -import CmdLineParser --- Implementations of the various modes (--show-iface, mkdependHS. etc.) -import LoadIface ( showIface ) -import HscMain ( newHscEnv ) -import DriverPipeline ( oneShot, compileFile ) -import DriverMkDepend ( doMkDependHS ) -#ifdef GHCI -import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) -#endif - --- Various other random stuff that we need -import Config -import HscTypes -import Packages ( dumpPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc, - startPhase, isHaskellSrcFilename ) -import BasicTypes ( failed ) -import StaticFlags -import StaticFlagParser -import DynFlags -import ErrUtils -import FastString -import Outputable -import SrcLoc -import Util -import Panic -import MonadUtils ( liftIO ) - -- Standard Haskell libraries import System.IO import System.Environment @@ -61,21 +17,10 @@ import Data.Word (Word) import Foreign.Storable (sizeOf) +import System.Cmd import qualified LhcMain as Lhc ------------------------------------------------------------------------------ --- ToDo: - --- time commands when run with -v --- user ways --- Win32 support: proper signal handling --- reading the package configuration file is too slow --- -K - ------------------------------------------------------------------------------ --- GHC's command-line interface - getLibdir = do appdir <- getAppUserDataDirectory "lhc" let targetARCH = arch @@ -84,550 +29,15 @@ return (appdir subdir) main :: IO () -main = do Lhc.tryMain -- This call will exit if it recognized the command arguments. +main = do Lhc.tryMain -- This call will terminate the program if it recognizes the command arguments. ghcMain -ghcMain :: IO () -ghcMain = - GHC.defaultErrorHandler defaultDynFlags $ do - -- 1. extract the -B flag from the args - argv0 <- getArgs - libdir <- getLibdir - let - (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 - mbMinusB | null minusB_args = Just libdir - | otherwise = Just (drop 2 (last minusB_args)) - wordSize = sizeOf (undefined :: Word) - let argv1' = map (mkGeneralLocated "on the commandline") ("-fext-core": - "-no-user-package-conf": - "-D__LHC__": - ("-DWORD_SIZE="++show wordSize): - argv1) - (argv2, staticFlagWarnings) <- parseStaticFlags argv1' - -- 2. Parse the "mode" flags (--make, --interactive etc.) - (m_uber_mode, cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 - - -- If all we want to do is to show the version number then do it - -- now, before we start a GHC session etc. - -- If we do it later then bootstrapping gets confused as it tries - -- to find out what version of GHC it's using before package.conf - -- exists, so starting the session fails. - case m_uber_mode of - -- ShowUsage currently has to be handled specially, as it needs to - -- actually start up GHC so that it can find the usage.txt files - -- in the libdir. It would be nice to embed the text in the - -- executable so that we don't have to do that, and things are more - -- uniform here. - Just ShowUsage -> return () - Just um -> - do case um of - ShowInfo -> showInfo - ShowSupportedLanguages -> showSupportedLanguages - ShowVersion -> showVersion - ShowNumVersion -> putStrLn (Version.showVersion version) - exitWith ExitSuccess - Nothing -> return () - - -- start our GHC session - GHC.runGhc mbMinusB $ do - - dflags0 <- GHC.getSessionDynFlags - - -- set the default GhcMode, HscTarget and GhcLink. The HscTarget - -- can be further adjusted on a module by module basis, using only - -- the -fvia-C and -fasm flags. If the default HscTarget is not - -- HscC or HscAsm, -fvia-C and -fasm have no effect. - let dflt_target = hscTarget dflags0 - (mode, lang, link) - = case cli_mode of - DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) - DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) - DoMake -> (CompManager, dflt_target, LinkBinary) - DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) - _ -> (OneShot, dflt_target, LinkBinary) - - let dflags1 = dflags0{ ghcMode = mode, - hscTarget = lang, - ghcLink = link, - -- leave out hscOutName for now - hscOutName = panic "Main.main:hscOutName not set", - verbosity = case cli_mode of - DoEval _ -> 0 - _other -> 1 - } - - -- turn on -fimplicit-import-qualified for GHCi now, so that it - -- can be overriden from the command-line - dflags1a | DoInteractive <- cli_mode = imp_qual_enabled - | DoEval _ <- cli_mode = imp_qual_enabled - | otherwise = dflags1 - where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified - - -- The rest of the arguments are "dynamic" - -- Leftover ones are presumably files - (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3 - - -- As noted earlier, currently we hvae to handle ShowUsage down here - case m_uber_mode of - Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode - _ -> return () - - let flagWarnings = staticFlagWarnings - ++ modeFlagWarnings - ++ dynamicFlagWarnings - liftIO $ handleFlagWarnings dflags2 flagWarnings - - -- make sure we clean up after ourselves - GHC.defaultCleanupHandler dflags2 $ do - - liftIO $ showBanner cli_mode dflags2 - - -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags dflags2 - dflags3 <- GHC.getSessionDynFlags - hsc_env <- GHC.getSession - - let - -- To simplify the handling of filepaths, we normalise all filepaths right - -- away - e.g., for win32 platforms, backslashes are converted - -- into forward slashes. - normal_fileish_paths = map (normalise . unLoc) fileish_args - (srcs, objs) = partition_args normal_fileish_paths [] [] - - -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on - -- the command-line. - liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs) - - ---------------- Display configuration ----------- - when (verbosity dflags3 >= 4) $ - liftIO $ dumpPackages dflags3 - - when (verbosity dflags3 >= 3) $ do - liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) - - ---------------- Final sanity checking ----------- - liftIO $ checkOptions cli_mode dflags3 srcs objs - - ---------------- Do the business ----------- - handleSourceError (\e -> do - GHC.printExceptionAndWarnings e - liftIO $ exitWith (ExitFailure 1)) $ do - case cli_mode of - PrintLibdir -> liftIO $ putStrLn (topDir dflags3) - ShowInterface f -> liftIO $ doShowIface dflags3 f - DoMake -> doMake srcs - DoMkDependHS -> doMkDependHS (map fst srcs) - StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings - DoInteractive -> interactiveUI srcs Nothing - DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs - - liftIO $ dumpFinalStats dflags3 - liftIO $ exitWith ExitSuccess - -#ifndef GHCI -interactiveUI :: b -> c -> Ghc () -interactiveUI _ _ = - ghcError (CmdLineError "not built for interactive use") -#endif - --- ----------------------------------------------------------------------------- --- Splitting arguments into source files and object files. This is where we --- interpret the -x option, and attach a (Maybe Phase) to each source --- file indicating the phase specified by the -x option in force, if any. - -partition_args :: [String] -> [(String, Maybe Phase)] -> [String] - -> ([(String, Maybe Phase)], [String]) -partition_args [] srcs objs = (reverse srcs, reverse objs) -partition_args ("-x":suff:args) srcs objs - | "none" <- suff = partition_args args srcs objs - | StopLn <- phase = partition_args args srcs (slurp ++ objs) - | otherwise = partition_args rest (these_srcs ++ srcs) objs - where phase = startPhase suff - (slurp,rest) = break (== "-x") args - these_srcs = zip slurp (repeat (Just phase)) -partition_args (arg:args) srcs objs - | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs - | otherwise = partition_args args srcs (arg:objs) - - {- - We split out the object files (.o, .dll) and add them - to v_Ld_inputs for use by the linker. - - The following things should be considered compilation manager inputs: - - - haskell source files (strings ending in .hs, .lhs or other - haskellish extension), - - - module names (not forgetting hierarchical module names), - - - and finally we consider everything not containing a '.' to be - a comp manager input, as shorthand for a .hs or .lhs filename. - - Everything else is considered to be a linker object, and passed - straight through to the linker. - -} -looks_like_an_input :: String -> Bool -looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m - || '.' `notElem` m - --- ----------------------------------------------------------------------------- --- Option sanity checks - --- | Ensure sanity of options. --- --- Throws 'UsageError' or 'CmdLineError' if not. -checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () - -- Final sanity checking before kicking off a compilation (pipeline). -checkOptions cli_mode dflags srcs objs = do - -- Complain about any unknown flags - let unknown_opts = [ f | (f@('-':_), _) <- srcs ] - when (notNull unknown_opts) (unknownFlagsErr unknown_opts) - - when (notNull (filter isRTSWay (wayNames dflags)) - && isInterpretiveMode cli_mode) $ - hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") - - -- -prof and --interactive are not a good combination - when (notNull (filter (not . isRTSWay) (wayNames dflags)) - && isInterpretiveMode cli_mode) $ - do ghcError (UsageError - "--interactive can't be used with -prof or -unreg.") - -- -ohi sanity check - if (isJust (outputHi dflags) && - (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) - then ghcError (UsageError "-ohi can only be used when compiling a single source file") - else do - - -- -o sanity checking - if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) - && not (isLinkMode cli_mode)) - then ghcError (UsageError "can't apply -o to multiple source files") - else do - - let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags) - - when (not_linking && not (null objs)) $ - hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) - - -- Check that there are some input files - -- (except in the interactive case) - if null srcs && (null objs || not_linking) && needsInputsMode cli_mode - then ghcError (UsageError "no input files") - else do - - -- Verify that output files point somewhere sensible. - verifyOutputFiles dflags - - --- Compiler output options - --- called to verify that the output files & directories --- point somewhere valid. --- --- The assumption is that the directory portion of these output --- options will have to exist by the time 'verifyOutputFiles' --- is invoked. --- -verifyOutputFiles :: DynFlags -> IO () -verifyOutputFiles dflags = do - -- not -odir: we create the directory for -odir if it doesn't exist (#2278). - let ofile = outputFile dflags - when (isJust ofile) $ do - let fn = fromJust ofile - flg <- doesDirNameExist fn - when (not flg) (nonExistentDir "-o" fn) - let ohi = outputHi dflags - when (isJust ohi) $ do - let hi = fromJust ohi - flg <- doesDirNameExist hi - when (not flg) (nonExistentDir "-ohi" hi) - where - nonExistentDir flg dir = - ghcError (CmdLineError ("error: directory portion of " ++ - show dir ++ " does not exist (used with " ++ - show flg ++ " option.)")) - ------------------------------------------------------------------------------ --- GHC modes of operation - -data UberMode - = ShowUsage -- ghc -? - | ShowVersion -- ghc -V/--version - | ShowNumVersion -- ghc --numeric-version - | ShowSupportedLanguages -- ghc --supported-languages - | ShowInfo -- ghc --info - deriving (Show) - -data CmdLineMode - = PrintLibdir -- ghc --print-libdir - | ShowInterface String -- ghc --show-iface - | DoMkDependHS -- ghc -M - | StopBefore Phase -- ghc -E | -C | -S - -- StopBefore StopLn is the default - | DoMake -- ghc --make - | DoInteractive -- ghc --interactive - | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] - deriving (Show) - -#ifdef GHCI -isInteractiveMode :: CmdLineMode -> Bool -isInteractiveMode DoInteractive = True -isInteractiveMode _ = False -#endif - --- isInterpretiveMode: byte-code compiler involved -isInterpretiveMode :: CmdLineMode -> Bool -isInterpretiveMode DoInteractive = True -isInterpretiveMode (DoEval _) = True -isInterpretiveMode _ = False - -needsInputsMode :: CmdLineMode -> Bool -needsInputsMode DoMkDependHS = True -needsInputsMode (StopBefore _) = True -needsInputsMode DoMake = True -needsInputsMode _ = False - --- True if we are going to attempt to link in this mode. --- (we might not actually link, depending on the GhcLink flag) -isLinkMode :: CmdLineMode -> Bool -isLinkMode (StopBefore StopLn) = True -isLinkMode DoMake = True -isLinkMode DoInteractive = True -isLinkMode (DoEval _) = True -isLinkMode _ = False - -isCompManagerMode :: CmdLineMode -> Bool -isCompManagerMode DoMake = True -isCompManagerMode DoInteractive = True -isCompManagerMode (DoEval _) = True -isCompManagerMode _ = False - - --- ----------------------------------------------------------------------------- --- Parsing the mode flag - -parseModeFlags :: [Located String] - -> IO (Maybe UberMode, - CmdLineMode, - [Located String], - [Located String]) -parseModeFlags args = do - let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = - runCmdLine (processArgs mode_flags args) - (Nothing, StopBefore StopLn, "", []) - when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (mUberMode, mode, flags' ++ leftover, warns) - -type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String]) - -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) - -- so we collect the new ones and return them. - -mode_flags :: [Flag ModeM] -mode_flags = - [ ------- help / version ---------------------------------------------- - Flag "?" (NoArg (setUberMode ShowUsage)) - Supported - , Flag "-help" (NoArg (setUberMode ShowUsage)) - Supported - , Flag "V" (NoArg (setUberMode ShowVersion)) - Supported - , Flag "-version" (NoArg (setUberMode ShowVersion)) - Supported - , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion)) - Supported - , Flag "-info" (NoArg (setUberMode ShowInfo)) - Supported - , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages)) - Supported - , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) - Supported - - ------- interfaces ---------------------------------------------------- - , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) - "--show-iface")) - Supported - - ------- primary modes ------------------------------------------------ - , Flag "M" (PassFlag (setMode DoMkDependHS)) - Supported - , Flag "E" (PassFlag (setMode (StopBefore anyHsc))) - Supported - , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fvia-C")) - Supported - , Flag "S" (PassFlag (setMode (StopBefore As))) - Supported - , Flag "-make" (PassFlag (setMode DoMake)) - Supported - , Flag "-interactive" (PassFlag (setMode DoInteractive)) - Supported - , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e")) - Supported - - -- -fno-code says to stop after Hsc but don't generate any code. - , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fno-code" - addFlag "-fforce-recomp")) - Supported - ] - -setUberMode :: UberMode -> ModeM () -setUberMode m = do - (_, cmdLineMode, flag, flags') <- getCmdLineState - putCmdLineState (Just m, cmdLineMode, flag, flags') - -setMode :: CmdLineMode -> String -> ModeM () -setMode m flag = updateMode (\_ -> m) flag - -updateDoEval :: String -> CmdLineMode -> CmdLineMode -updateDoEval expr (DoEval exprs) = DoEval (expr : exprs) -updateDoEval expr _ = DoEval [expr] - -updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM () -updateMode f flag = do - (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState - if null old_flag || flag == old_flag - then putCmdLineState (m_uber_mode, f old_mode, flag, flags') - else ghcError (UsageError - ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) - -addFlag :: String -> ModeM () -addFlag s = do - (u, m, f, flags') <- getCmdLineState - -- XXX Can we get a useful Loc? - putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') - - --- ---------------------------------------------------------------------------- --- Run --make mode - -doMake :: [(String,Maybe Phase)] -> Ghc () -doMake [] = ghcError (UsageError "no input files") -doMake srcs = do - let (hs_srcs, non_hs_srcs) = partition haskellish srcs - - haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = - phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] - - hsc_env <- GHC.getSession - o_files <- mapM (\x -> do - f <- compileFile hsc_env StopLn x - GHC.printWarnings - return f) - non_hs_srcs - liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) - - targets <- mapM (uncurry GHC.guessTarget) hs_srcs - GHC.setTargets targets - ok_flag <- GHC.load LoadAllTargets - - when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) - return () - - --- --------------------------------------------------------------------------- --- --show-iface mode - -doShowIface :: DynFlags -> FilePath -> IO () -doShowIface dflags file = do - hsc_env <- newHscEnv dflags - showIface hsc_env file - --- --------------------------------------------------------------------------- --- Various banners and verbosity output. - -showBanner :: CmdLineMode -> DynFlags -> IO () -showBanner _cli_mode dflags = do - let verb = verbosity dflags - -#ifdef GHCI - -- Show the GHCi banner - when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg -#endif - - -- Display details of the configuration in verbose mode - when (verb >= 2) $ - do hPutStrLn stderr ("The Luxurious LHC Haskell Optimization System, version " ++ Version.showVersion version) - hPutStr stderr "Using frontend: Glasgow Haskell Compiler, Version " - hPutStr stderr cProjectVersion - hPutStr stderr ", for Haskell 98, stage " - hPutStr stderr cStage - hPutStr stderr " booted by GHC version " - hPutStrLn stderr cBooterVersion - --- We print out a Read-friendly string, but a prettier one than the --- Show instance gives us -showInfo :: IO () -showInfo = do - let sq x = " [" ++ x ++ "\n ]" - putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo - exitWith ExitSuccess - -showSupportedLanguages :: IO () -showSupportedLanguages = do mapM_ putStrLn supportedLanguages - exitWith ExitSuccess - -showVersion :: IO () -showVersion = do - putStrLn ("The Luxurious LHC Haskell Optimization System, version " ++ Version.showVersion version) - putStrLn ("Using frontend: " ++ cProjectName ++ ", version " ++ cProjectVersion) - exitWith ExitSuccess - -showGhcUsage :: DynFlags -> CmdLineMode -> IO () -showGhcUsage dflags cli_mode = do - let usage_path - | DoInteractive <- cli_mode = ghciUsagePath dflags - | otherwise = ghcUsagePath dflags - usage <- readFile usage_path - dump usage - exitWith ExitSuccess - where - dump "" = return () - dump ('$':'$':s) = putStr progName >> dump s - dump (c:s) = putChar c >> dump s - -dumpFinalStats :: DynFlags -> IO () -dumpFinalStats dflags = - when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags - -dumpFastStringStats :: DynFlags -> IO () -dumpFastStringStats dflags = do - buckets <- getFastStringTable - let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets - msg = text "FastString stats:" $$ - nest 4 (vcat [text "size: " <+> int (length buckets), - text "entries: " <+> int entries, - text "longest chain: " <+> int longest, - text "z-encoded: " <+> (is_z `pcntOf` entries), - text "has z-encoding: " <+> (has_z `pcntOf` entries) - ]) - -- we usually get more "has z-encoding" than "z-encoded", because - -- when we z-encode a string it might hash to the exact same string, - -- which will is not counted as "z-encoded". Only strings whose - -- Z-encoding is different from the original string are counted in - -- the "z-encoded" total. - putMsg dflags msg - where - x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' - -countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) -countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) -countFS entries longest is_z has_z (b:bs) = - let - len = length b - longest' = max len longest - entries' = entries + len - is_zs = length (filter isZEncoded b) - has_zs = length (filter hasZEncoding b) - in - countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs - --- ----------------------------------------------------------------------------- --- Util - -unknownFlagsErr :: [String] -> a -unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs)) +ghcMain :: IO () +ghcMain = do libdir <- getLibdir + args <- getArgs + let wordSize = sizeOf (undefined :: Word) + system $ unwords (["ghc","-fext-core","-B"++libdir,"-no-user-package-conf","-D__LHC__" + ,"-DWORD_SIZE="++show wordSize + ,"-DWORD_SIZE_IN_BITS="++show (wordSize*8)] ++ args) + return () diff --git a/src/Grin/DeadCode.hs b/src/Grin/DeadCode.hs new file mode 100644 --- /dev/null +++ b/src/Grin/DeadCode.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +module Grin.DeadCode + ( removeDeadCode + ) where + +import Grin.Types + +import qualified Data.Map as Map +import qualified Data.Set as Set + + +removeDeadCode :: Grin -> Grin +removeDeadCode grin + = let dependenciesMap :: Map.Map Renamed (Set.Set Renamed) + dependenciesMap = grinDepends grin + loop seen keys + = let deps = Set.unions [ find dependenciesMap key | key <- keys ] + newDeps = deps `Set.difference` seen + in if Set.null newDeps + then seen + else loop (seen `Set.union` newDeps) (Set.toList newDeps) + neededDependencies = Set.insert entryPoint $ loop Set.empty [entryPoint] + in grin { grinFunctions = [ func | func <- grinFunctions grin, funcDefName func `Set.member` neededDependencies ] + , grinCAFs = [ caf | caf <- grinCAFs grin, cafName caf `Set.member` neededDependencies ] + , grinNodes = [ node | node <- grinNodes grin, nodeName node `Set.member` neededDependencies ] + } + where find m k = case Map.lookup k m of + Just v -> v + Nothing -> error $ "Grin.DeadCode.removeDeadCode: Couldn't find key: " ++ show k + entryPoint = grinEntryPoint grin + + +grinDepends :: Grin -> Map.Map Renamed (Set.Set Renamed) +grinDepends grin + = Map.fromList [ (funcDefName def, defDepends def) | def <- grinFunctions grin ] `Map.union` + Map.fromList [ (cafName caf, valueDepends (cafValue caf)) | caf <- grinCAFs grin ] `Map.union` + Map.fromList [ (nodeName node, Set.empty) | node <- grinNodes grin ] + +defDepends :: FuncDef -> Set.Set Renamed +defDepends def + = expDepends (funcDefBody def) `Set.difference` Set.fromList (funcDefArgs def) + +expDepends :: Expression -> Set.Set Renamed +expDepends (Store v) = valueDepends v +expDepends (Unit v) = valueDepends v +expDepends (Update size ptr val) + = Set.fromList [ptr,val] +expDepends (Application fn args) | isBuiltin fn + = Set.fromList args +expDepends (Application fn args) | isExternal fn + = Set.fromList args +expDepends (Application fn args) + = Set.fromList (fn:args) +expDepends (Case scrut alts) + = Set.insert scrut $ Set.unions (map altDepends alts) +expDepends (a :>> b) + = expDepends a `Set.union` expDepends b +expDepends (a :>>= bind :-> b) + = expDepends a `Set.union` Set.delete bind (expDepends b) + +altDepends :: Alt -> Set.Set Renamed +altDepends (Node tag _nt _missing args :> branch) + = Set.insert tag $ expDepends branch `Set.difference` Set.fromList args +altDepends (cond :> branch) + = expDepends branch `Set.difference` valueDepends cond + +valueDepends :: Value -> Set.Set Renamed +valueDepends (Node tag _nt _missing args) + = Set.fromList (tag:args) +valueDepends (Vector args) + = Set.fromList args +valueDepends Lit{} = Set.empty +valueDepends (Variable v) = Set.singleton v +valueDepends Hole{} = Set.empty +valueDepends Empty = Set.empty + diff --git a/src/Grin/Eval/Compile.hs b/src/Grin/Eval/Compile.hs --- a/src/Grin/Eval/Compile.hs +++ b/src/Grin/Eval/Compile.hs @@ -13,31 +13,24 @@ import qualified Data.Map as Map import Control.Monad.Reader -import CompactString import Grin.Types hiding (Value(..)) import qualified Data.Map as Map import Control.Monad.State import Data.Char -import Data.IORef; import System.IO.Unsafe -runGrin :: Grin -> String -> [String] -> IO EvalValue -runGrin grin entry commandArgs +runGrin :: Grin -> [String] -> IO EvalValue +runGrin grin commandArgs = let globalScope = GlobalScope { globalCAFs = Map.fromList cafs , globalFuncs = Map.fromList (funcs ++ prims) } cafs = zip (map cafName (grinCAFs grin)) [0..] funcs = [ (funcDefName def, compFuncDef def globalScope) | def <- grinFunctions grin ] prims = listPrimitives globalScope - apply = lookupFunction (Builtin $ fromString "evalApply") globalScope in runComp $ do mapM_ storeValue =<< mapM (\caf -> compValue (cafValue caf) globalScope) (grinCAFs grin) setCommandArgs ("lhc":commandArgs) - entry <- lookupVariable renamedEntry globalScope - apply [entry, realWorld] - where renamedEntry = case [ cafName caf | caf <- grinCAFs grin, Just name <- [alias (cafName caf)], name == fromString entry ] of - [] -> error $ "Grin.Eval.Basic.evaluate: couldn't find entry point: " ++ entry - (name:_) -> name + lookupFunction (grinEntryPoint grin) globalScope [] runComp comp = runReaderT (evalStateT (unComp comp) initState) Map.empty @@ -45,18 +38,6 @@ , stateFree = 0 , stateArgs = ["lhc"] } -{-# NOINLINE indent #-} -indent :: IORef Int -indent = unsafePerformIO (newIORef 0) - -withIndent str fn - = do n <- liftIO $ readIORef indent - liftIO $ putStrLn $ replicate n ' ' ++ str - liftIO $ writeIORef indent (n+2) - ret <- fn - liftIO $ writeIORef indent n - return ret - compFuncDef :: FuncDef -> Gen CompFunction compFuncDef func = do exp <- compExpression (funcDefBody func) @@ -78,7 +59,6 @@ = do fn <- lookupFunction name args' <- mapM lookupVariable args return $ do args'' <- mapM id args' - --withIndent ("Running: " ++ show name ++ " " ++ show args ++ " " ++ show args'') $ fn args'' compExpression (Unit value) = compValue value @@ -116,10 +96,10 @@ runCase :: EvalValue -> [(Grin.Value, CompValue)] -> CompValue runCase val cases = worker cases - where worker (x@(Grin.Variable{}, e) : y : ys) - = worker (y:x:ys) - worker [(Grin.Variable name, e)] + where worker [(Grin.Variable name, e)] = local (Map.insert name val) e + worker ((Grin.Variable name, e):_) + = error "Default matches would always be last." worker ((b,c):xs) = case doesMatch val b of Nothing -> worker xs @@ -142,12 +122,6 @@ doesMatch from to = Nothing - -bindLambda :: EvalValue -> Grin.Value -> CompValue -> CompValue -bindLambda from to - = case doesMatch from to of - Nothing -> error $ "bindLambda: " ++ show (from, to) - Just fn -> fn bindLambdas :: [(EvalValue, Grin.Value)] -> Maybe (CompValue -> CompValue) bindLambdas [] = Just id diff --git a/src/Grin/Eval/Methods.hs b/src/Grin/Eval/Methods.hs --- a/src/Grin/Eval/Methods.hs +++ b/src/Grin/Eval/Methods.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} module Grin.Eval.Methods where -import CompactString import Grin.Types hiding (Value) import qualified Grin.Types as Grin import Grin.Eval.Types diff --git a/src/Grin/Eval/Primitives.hs b/src/Grin/Eval/Primitives.hs --- a/src/Grin/Eval/Primitives.hs +++ b/src/Grin/Eval/Primitives.hs @@ -53,26 +53,17 @@ returnIO (Lit (Lint 512)) ("fdReady", [fd,write,msecs,isSock]) -> returnIO (Lit (Lint 1)) - ("rtsSupportsBoundThreads", []) -> - returnIO (Lit (Lint 1)) - ("stg_sig_install", [signo, actioncode, ptr]) -> - returnIO (Lit (Lint 0)) ("getProgArgv", [Lit (Lint argcPtr), Lit (Lint argvPtr)]) -> do args <- getCommandArgs liftIO $ poke (nullPtr `plusPtr` fromIntegral argcPtr) (fromIntegral (length args) :: CInt) cs <- liftIO $ newArray =<< mapM newCString args liftIO $ poke (nullPtr `plusPtr` fromIntegral argvPtr) cs return $ Vector [Empty] - ("u_iswlower", [Lit (Lint ch)]) -> - do returnIO $ Lit (Lint (fromIntegral (fromEnum (isLower (chr (fromIntegral ch)))))) - ("u_iswalpha", [Lit (Lint ch)]) -> - do returnIO $ Lit (Lint (fromIntegral (fromEnum (isAlpha (chr (fromIntegral ch)))))) - ("u_iswspace", [Lit (Lint ch)]) -> - do returnIO $ Lit (Lint (fromIntegral (fromEnum (isSpace (chr (fromIntegral ch)))))) (name, args) -> -- If we don't recognize the function, try loading it through the linker. do fnPtr <- liftIO $ dlsym Default name let toCArg (Lit (Lint i)) = argCInt (fromIntegral i) + toCArg _ = error $ "Grin.Eval.Primitive.runExternal: Unrecognized argument type." ret <- liftIO $ callFFI fnPtr retCInt (map toCArg args) returnIO $ Lit (Lint (fromIntegral ret)) diff --git a/src/Grin/Eval/Types.hs b/src/Grin/Eval/Types.hs --- a/src/Grin/Eval/Types.hs +++ b/src/Grin/Eval/Types.hs @@ -7,7 +7,6 @@ import qualified Data.Map as Map import Control.Monad.Reader -import CompactString import Grin.Types hiding (Value(..)) import qualified Data.Map as Map diff --git a/src/Grin/FromCore.hs b/src/Grin/FromCore.hs --- a/src/Grin/FromCore.hs +++ b/src/Grin/FromCore.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, OverloadedStrings #-} module Grin.FromCore ( coreToGrin ) where @@ -18,26 +18,40 @@ data Env = Env { scope :: Map.Map Variable Renamed + , enums :: Map.Map CompactString [Renamed] , arities :: Map.Map Variable Int } -emptyEnv = Env Map.empty Map.empty +emptyEnv = Env Map.empty Map.empty Map.empty type M a = ReaderT Env (State Int) a -coreToGrin :: [SimpleType] -> [SimpleDef] -> Grin -coreToGrin tdefs defs +coreToGrin :: [SimpleType] -> [SimpleEnum] -> [SimpleDef] -> Grin +coreToGrin tdefs senums defs = let gen = tdefsToNodes tdefs $ \nodes -> let (defs',cafs) = splitCAFs defs in bindCAFs cafs $ + bindEnums senums $ defsToFuncs defs' $ \funcs -> defsToCAFs cafs $ \cafs' -> - get >>= \u -> - asks scope >>= \varScope -> - return (GHCism.lower varScope Grin { grinNodes = nodes - , grinCAFs = cafs' - , grinFunctions = funcs - , grinUnique = u - }) + do entryPoint <- genEntryPoint + u <- get + varScope <- asks scope + return (GHCism.lower varScope Grin { grinNodes = nodes + , grinCAFs = cafs' + , grinFunctions = entryPoint : funcs + , grinEntryPoint = funcDefName entryPoint + , grinUnique = u + }) + genEntryPoint = do mainCaf <- lookupVariable "main::Main.main" + realWorld <- newVariable + name <- newVariable + v <- newVariable + return FuncDef { funcDefName = name + , funcDefArgs = [] + , funcDefBody = Application (Builtin "realWorld#") [] :>>= realWorld :-> + Application (Builtin "eval") [mainCaf] :>>= v :-> + Application (Builtin "apply") [v,realWorld] + } in evalState (runReaderT gen emptyEnv) 0 tdefsToNodes :: [SimpleType] -> ([NodeDef] -> M a) -> M a @@ -52,6 +66,13 @@ return (NodeDef name ConstructorNode (replicate (simpleTypeArity stype) PtrType)) +bindEnums :: [SimpleEnum] -> M a -> M a +bindEnums [] fn = fn +bindEnums (x:xs) fn + = do lookupVariable (simpleEnumName x) + members <- mapM lookupVariable (simpleEnumMembers x) + local (\env -> env{enums = Map.insert (simpleEnumName x) members (enums env)}) (bindEnums xs fn) + splitCAFs :: [SimpleDef] -> ([SimpleDef], [(Variable,Variable)]) splitCAFs [] = ([],[]) splitCAFs (x:xs) @@ -102,19 +123,23 @@ Simple.CaseStrict exp binding alts -> bindVariable binding $ \renamed -> do e <- translate Strict exp - alts' <- mapM (alternative (translate cxt)) alts + alts' <- alternatives cxt alts return $ e :>>= renamed :-> Grin.Case renamed alts' Simple.Case exp binding alts | simpleExpIsPrimitive exp -> bindVariable binding $ \renamed -> do e <- translate cxt exp - alts' <- mapM (alternative (translate cxt)) alts + alts' <- alternatives cxt alts return $ e :>>= renamed :-> Grin.Case renamed alts' Simple.Case exp binding alts -> bindVariable binding $ \renamed -> do e <- translate Strict exp v <- newVariable - alts' <- mapM (alternative (translate cxt)) alts + alts' <- alternatives cxt alts return $ e :>>= v :-> Store (Variable v) :>>= renamed :-> Grin.Case v alts' + Simple.EnumPrimitive "tagToEnum#" arg t + -> translateTagToEnum cxt arg t + Simple.EnumPrimitive "dataToTag#" arg t + -> translateDataToTag cxt arg t Simple.Primitive p -> return $ Application (Builtin p) [] Var var isUnboxed -> @@ -140,7 +165,9 @@ do func' <- lookupVariable func args' <- mapM lookupVariable args e' <- translate cxt e - return $ Store (Node func' FunctionNode (arity-length args) args') :>>= bind' :-> e' + if arity == 0 + then return $ Unit (Variable func') :>>= bind' :-> e' + else return $ Store (Node func' FunctionNode (arity-length args) args') :>>= bind' :-> e' LetStrict bind fn e -> bindVariable bind $ \bind' -> do fn' <- translate Strict fn @@ -154,8 +181,12 @@ r <- process (v:acc) xs return $ e :>>= v :-> r call vs = case fn of - Simple.Primitive p -> return $ Application (Builtin p) vs - Simple.External e _ _ -> return $ Application (Grin.External e) vs + Simple.Primitive p + | isBooleanPrimitive p, Lazy <- cxt + -> do n <- newVariable + return $ Application (Builtin p) vs :>>= n :-> Store (Variable n) + | otherwise -> return $ Application (Builtin p) vs + Simple.External e _ tys -> return $ Application (Grin.External e tys) vs Var var isUnboxed -> do name <- lookupVariable var mbArity <- findArity var case mbArity of @@ -198,6 +229,8 @@ r <- loop v' xs return $ eval v :>>= v' :-> r in process [] args + LetRec [(bind,func,args,arity)] e | bind `notElem` args -> + translate cxt (Let bind func args arity e) LetRec defs e -> let binds = [ bind | (bind,_,_,_) <- defs ] funcs = [ func | (_,func,_,_) <- defs ] @@ -216,7 +249,7 @@ Note _ e -> translate cxt e -- Label str -> error $ "label: " ++ str - Simple.External fn conv _ -> return $ Unit $ Variable $ Grin.External fn + Simple.External fn conv tys -> return $ Unit $ Variable $ Grin.External fn tys -- DynExternal fn -> error $ "dynexternal: " ++ fn _ -> return $ Unit Empty @@ -231,11 +264,47 @@ , (fromString "ghc-prim:GHC.Prim.(#,,,,,#)", 6) , (fromString "ghc-prim:GHC.Prim.(#,,,,,,#)", 7) , (fromString "ghc-prim:GHC.Prim.(#,,,,,,,#)", 8) + , (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,#)", 9) + , (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,#)", 10) + , (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,,#)", 11) + , (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,,,#)", 12) ] + {- +tagToEnum @ Bool arg +======> +do case arg of + 0# -> Unit False + 1# -> Unit True +-} +translateTagToEnum cxt arg (Tcon ty) + = do members <- lookupEnum ty + argName <- lookupVariable arg + let fn = case cxt of Strict -> Unit; Lazy -> Store + return $ Grin.Case argName [ Grin.Lit (Lint n) :> fn (Node member ConstructorNode 0 []) | (n, member) <- zip [0..] members ] +{- +dataToTag @ Bool arg +======> +do node <- fetch arg + case node of + False -> Unit 0# + True -> Unit 1# +-} +translateDataToTag cxt arg (Tcon ty) + = do members <- lookupEnum ty + argName <- lookupVariable arg + let fn = case cxt of Strict -> Unit; Lazy -> Store + node <- newVariable + return $ Application (Builtin "fetch") [argName] :>>= node :-> + Grin.Case node [ Grin.Node member ConstructorNode 0 [] :> fn (Grin.Lit (Lint n)) | (n, member) <- zip [0..] members ] + + + +{- + -- const application fn f = f 10 fn f = eval f >>= \v -> apply v (Lit 10) @@ -252,11 +321,18 @@ update bind fn args arity var = Unit (Node fn FunctionNode (arity-length args) args) :>>= var :-> - Application (Builtin $ fromString "update") [bind, var] + Update (length args + 1) bind var eval v = Application (Builtin $ fromString "eval") [v] apply a b = Application (Builtin $ fromString "apply") [a,b] applyCell a b = Store (Node (Builtin $ fromString "evalApply") FunctionNode 0 [a,b]) +alternatives :: Context -> [Simple.Alt] -> M [Grin.Alt] +alternatives cxt alts + = mapM (alternative (translate cxt)) (others ++ defaults) + where isDefault Adefault{} = True + isDefault _ = False + (defaults,others) = partition isDefault alts + -- Translate a Core alternative to a Grin alternative alternative :: (SimpleExp -> M Expression) -> Simple.Alt -> M Grin.Alt alternative fn (Acon con bs e) | Just n <- dconIsVector con @@ -277,6 +353,8 @@ return $ Grin.Lit lit :> e' simpleExpIsPrimitive :: SimpleExp -> Bool +simpleExpIsPrimitive (App (Simple.Primitive prim) _) | isBooleanPrimitive prim + = False simpleExpIsPrimitive (App Simple.Primitive{} _) = True simpleExpIsPrimitive (App Simple.External{} _) @@ -285,6 +363,11 @@ simpleExpIsPrimitive _ = False +isBooleanPrimitive x = x `elem` [">=#",">#","==#","/=#","<=#","<#","<##",">##",">=##","<=##","==##" + ,"eqWord#", "neWord#", "leWord#", "gtFloat#", "ltFloat#", "geFloat#" + ,"leFloat#", "eqFloat#"] + + {- let a = 1:b b = 0:a @@ -327,7 +410,12 @@ lookupVariable :: Variable -> M Renamed lookupVariable var = asks $ \env -> Map.findWithDefault err var (scope env) - where err = error $ "Variable not found: " ++ show var + where err = error $ "Grin.FromCore.lookupVariable: Variable not found: " ++ show var + +lookupEnum :: CompactString -> M [Renamed] +lookupEnum tyName + = asks $ \env -> Map.findWithDefault err tyName (enums env) + where err = error $ "Grin.FromCore.lookupEnum: Enum not found: " ++ show tyName bindSimpleDef :: SimpleDef -> M a -> M a bindSimpleDef sdef fn diff --git a/src/Grin/HPT.hs b/src/Grin/HPT.hs --- a/src/Grin/HPT.hs +++ b/src/Grin/HPT.hs @@ -1,15 +1,20 @@ module Grin.HPT ( analyze , lower + , mkEnvironment + , module Grin.HPT.Interface + , Lhs (..) ) where import Grin.Types ( Grin ) -import Grin.HPT.Environment ( mkEnvironment ) -import Grin.HPT.Solve ( solve, HeapAnalysis ) +import Grin.HPT.Environment ( mkEnvironment, Lhs(..) ) +--import Grin.HPT.Solve ( ) +import Grin.HPT.QuickSolve ( ) +import Grin.HPT.FastSolve ( solve ) import Grin.HPT.Lower ( lower ) - +import Grin.HPT.Interface -analyze :: Grin -> (Int, HeapAnalysis) +analyze :: Grin -> ([HeapAnalysis], HeapAnalysis) analyze = solve . mkEnvironment diff --git a/src/Grin/HPT/Environment.hs b/src/Grin/HPT/Environment.hs --- a/src/Grin/HPT/Environment.hs +++ b/src/Grin/HPT/Environment.hs @@ -4,12 +4,16 @@ , Equations , Rhs(..) , RhsValue(..) + , HeapPointer , Lhs(..) + , Node , singleton + , isSubsetOf ) where import CompactString -import Grin.Types +import Grin.Types hiding (Update) +import qualified Grin.Types as Grin import qualified Data.Map as Map import Control.Monad.RWS @@ -17,13 +21,21 @@ import Control.Monad.Reader import Control.Monad.Writer +import Control.Parallel.Strategies + type HeapPointer = Int data Lhs = HeapEntry HeapPointer | VarEntry Renamed - deriving (Eq,Ord) + deriving (Eq,Ord,Show) +instance NFData Lhs where + rnf (HeapEntry hp) = () + rnf (VarEntry r) = () + +type Node = (Renamed, NodeType, Int) -- Name, node type, missing arguments. + data RhsValue - = Extract Renamed Renamed Int + = Extract Renamed Node Int | ExtractVector Renamed Int | Eval Renamed | Update Renamed Renamed @@ -57,16 +69,34 @@ LT -> Tag tag1 nt1 missing1 args1 : worker xs (Tag tag2 nt2 missing2 args2:ys) GT -> Tag tag2 nt2 missing2 args2 : worker (Tag tag1 nt1 missing1 args1:xs) ys EQ -> Tag tag1 nt1 (min missing1 missing2) (zipJoin args1 args2):worker xs ys - worker (y@Tag{}:ys) (x:xs) + worker (VectorTag v1:xs) (VectorTag v2:ys) + = VectorTag (zipJoin v1 v2) : worker xs ys +{- worker (y@Tag{}:ys) (x:xs) = x:worker (y:ys) xs worker (y:ys) (x@Tag{}:xs) - = y:worker ys (x:xs) + = y:worker ys (x:xs)-} worker (y:ys) (x:xs) = case y `compare` x of LT -> y:worker ys (x:xs) GT -> x:worker (y:ys) xs EQ -> x:worker ys xs +isSubsetOf :: Rhs -> Rhs -> Bool +Rhs lRhs `isSubsetOf` Rhs rRhs + = worker lRhs rRhs + where worker [] y = True + worker x [] = False + worker (x@(Tag tag1 _ _ args1):xs) (y@(Tag tag2 _ _ args2):ys) + = case tag1 `compare` tag2 of + LT -> False + GT -> worker (x:xs) ys + EQ -> and (zipWith isSubsetOf args1 args2) && worker xs ys + worker (x:xs) (y:ys) + = case x `compare` y of + LT -> False + GT -> worker (x:xs) ys + EQ -> worker xs ys + zipJoin :: Monoid a => [a] -> [a] -> [a] zipJoin [] [] = [] zipJoin [] lst = zipWith mappend (repeat mempty) lst @@ -99,24 +129,39 @@ addEquation (VarEntry (funcDefName function)) rhs forM_ (zip (funcDefArgs function) [0..]) $ \(arg, n) -> addEquation (VarEntry arg) - (singleton $ Extract applications (funcDefName function) n) + (singleton $ Extract applications (funcDefName function, FunctionNode, 0) n) -- FIXME: Put these in order. baseBuiltins, vectorBuiltins, unsupportedBuiltins :: [CompactString] baseBuiltins = ["<#",">#","<=#",">=#","-#","+#","*#","narrow32Int#" ,"uncheckedIShiftRA#","and#","==#", "remInt#", "noDuplicate#" - ,"narrow8Word#", "writeInt8OffAddr#" + ,"narrow8Word#", "writeInt8OffAddr#", "writeWord8OffAddr#", "writeWord64OffAddr#" ,"narrow8Int#", "byteArrayContents#","touch#" - ,"uncheckedIShiftL#", "negateInt#" + ,"uncheckedIShiftL#", "negateInt#", "not#" ,"indexCharOffAddr#","minusWord#","geWord#","eqWord#","narrow16Word#" + ,"neWord#", "ltWord#", "gtWord#", "remWord#" ,"ord#","chr#","or#","narrow32Word#","uncheckedShiftL#","plusWord#" - ,"uncheckedShiftRL#","neChar#","gcdInt#","narrow16Int#","timesWord#" - ,"writeAddrOffAddr#","writeInt32OffAddr#","quotInt#" - ,"leWord#","/=#","writeCharArray#","xor#" ] + ,"uncheckedShiftRL#","neChar#","narrow16Int#","timesWord#" + ,"writeAddrOffAddr#","writeInt32OffAddr#","quotInt#", "quotWord#" + ,"writeDoubleOffAddr#" + ,"leWord#","/=#","writeCharArray#","xor#", "realWorld#" + ,"waitWrite#", "negateDouble#", "negateFloat#", "sqrtDouble#", "expDouble#", "**##" + ,"sinDouble#", "tanDouble#", "cosDouble#", "asinDouble#", "atanDouble#" + ,"acosDouble#", "asinhDouble#", "sinhDouble#", "tanhDouble#", "coshDouble#" + ,"<##", "==##", ">##", "<=##", ">=##", "-##", "+##", "*##", "/##" + ,"ltFloat#", "eqFloat#", "writeWord8Array#" + ,"coerceDoubleToWord", "coerceWordToDouble", "logDouble#", "int2Double#", "double2Int#" + ,"int2Float#", "divideFloat#", "timesFloat#", "minusFloat#", "plusFloat#" + ,"gtFloat#", "geFloat#", "leFloat#", "sqrtFloat#" + ,"writeWideCharOffAddr#" ] vectorBuiltins = ["unsafeFreezeByteArray#", "newAlignedPinnedByteArray#" - , "word2Integer#","integer2Int#", "newPinnedByteArray#" - ,"readInt8OffAddr#","readInt32OffAddr#","readAddrOffAddr#","readInt32OffAddr#"] -unsupportedBuiltins = ["raise#","atomicModifyMutVar#","waitWrite#","mkWeak#","writeTVar#" + ,"word2Integer#","integer2Int#", "newByteArray#", "newPinnedByteArray#" + ,"readInt8OffAddr#","readInt32OffAddr#","readWord64OffAddr#","readWord8OffAddr#" + ,"readAddrOffAddr#","readInt32OffAddr#" + ,"readWord8Array#", "readDoubleOffAddr#", "writeDoubleOffAddr#" + ,"mkWeak#", "readCharArray#" + ,"readWideCharOffAddr#"] +unsupportedBuiltins = ["raise#","atomicModifyMutVar#","writeTVar#" ,"raiseIO#","fork#","atomically#"] @@ -137,9 +182,10 @@ = do let valRhs = singleton $ Ident val rets <- forM alts $ \(l :> alt) -> case l of - Node tag _ _ args -> do forM_ (zip [0..] args) $ \(n,arg) -> - addEquation (VarEntry arg) (singleton $ Extract val tag n) - setupEnv alt + Node tag nt missing args + -> do forM_ (zip [0..] args) $ \(n,arg) -> + addEquation (VarEntry arg) (singleton $ Extract val (tag, nt, missing) n) + setupEnv alt Vector args -> do forM_ (zip [0..] args) $ \(n,arg) -> addEquation (VarEntry arg) (singleton $ ExtractVector val n) setupEnv alt @@ -149,29 +195,40 @@ _ -> error $ "setupEnv: Invalid case: " ++ show l return $ mconcat rets setupEnv (Application External{} args) - = return $ singleton (VectorTag [mempty, singleton Base]) + = return $ singleton (VectorTag [singleton Base, singleton Base]) setupEnv (Application (Builtin "eval") [arg]) = do return $ singleton (Eval arg) setupEnv (Application (Builtin "apply") [arg1, arg2]) = do addEquation (VarEntry applications) (singleton $ PartialApply arg1 arg2) return $ singleton (Apply arg1 arg2) -setupEnv (Application (Builtin "update") [ptr,val]) +--setupEnv (Application (Builtin "update") [ptr,val]) +-- = do addEquation (VarEntry updates) (singleton $ Update ptr val) +-- return mempty +setupEnv (Grin.Update size ptr val) = do addEquation (VarEntry updates) (singleton $ Update ptr val) return mempty +setupEnv (Application (Builtin "newMutVar") [val, realWorld]) + = do hp <- store =<< processVal (Variable val) + return $ singleton $ VectorTag [ singleton Base, singleton $ Heap hp ] +setupEnv (Application (Builtin "updateMutVar") [ptr, val, realWorld]) + = do addEquation (VarEntry updates) (singleton $ Update ptr val) + return $ singleton Base +setupEnv (Application (Builtin "readMutVar") [val, realWorld]) + = return $ singleton $ VectorTag [ singleton Base, singleton $ Fetch val ] setupEnv (Application (Builtin fn) args) | fn `elem` baseBuiltins = return $ singleton Base setupEnv (Application (Builtin fn) args) | fn `elem` vectorBuiltins - = return $ singleton $ VectorTag [mempty, singleton Base] + = return $ singleton $ VectorTag [singleton Base, singleton Base] setupEnv (Application (Builtin fn) args) | fn `elem` unsupportedBuiltins = return mempty setupEnv (Application (Builtin "makeStablePtr#") [val,realworld]) = do hp <- store (singleton $ Ident val) - return $ singleton $ VectorTag [mempty, singleton $ Heap hp] + return $ singleton $ VectorTag [singleton Base, singleton $ Heap hp] setupEnv (Application (Builtin "deRefStablePtr#") [ptr,realworld]) - = do return $ singleton $ VectorTag [mempty, singleton $ Fetch ptr] + = do return $ singleton $ VectorTag [singleton Base, singleton $ Fetch ptr] setupEnv (Application (Builtin "unblockAsyncExceptions#") [fn, realworld]) = do return $ singleton $ Apply fn realworld setupEnv (Application (Builtin "blockAsyncExceptions#") [fn, realworld]) @@ -180,12 +237,16 @@ = return $ singleton $ Fetch a setupEnv (Application (Builtin "newArray#") [size, elt, realworld]) = do hp <- store (singleton $ Ident elt) - return $ singleton $ VectorTag [mempty, singleton $ Heap hp] + return $ singleton $ VectorTag [singleton Base, singleton $ Heap hp] setupEnv (Application (Builtin "readArray#") [arr, nth, realworld]) - = return $ singleton $ VectorTag [mempty, singleton $ Fetch arr] + = return $ singleton $ VectorTag [singleton Base, singleton $ Fetch arr] +setupEnv (Application (Builtin "unsafeFreezeArray#") [arr, realworld]) + = return $ singleton $ VectorTag [singleton Base, singleton $ Ident arr] +setupEnv (Application (Builtin "indexArray#") [arr, nth]) + = return $ singleton $ VectorTag [singleton $ Fetch arr ] setupEnv (Application (Builtin "writeArray#") [arr, nth, elt, realworld]) = do addEquation (VarEntry updates) (singleton $ Update arr elt) - return mempty + return (singleton Base) setupEnv (Application (Builtin builtin) args) = error $ "unknown builtin: " ++ show builtin diff --git a/src/Grin/HPT/FastSolve.hs b/src/Grin/HPT/FastSolve.hs new file mode 100644 --- /dev/null +++ b/src/Grin/HPT/FastSolve.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +module Grin.HPT.FastSolve + ( solve + ) where + +import Grin.Types ( Renamed(..), NodeType(..) ) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State.Strict + +import Grin.HPT.Environment as Env +import Grin.HPT.Interface as Interface +import qualified Grin.HPT.Interface as Interface + +import Grin.Stage2.Pretty (ppRenamed) + +import Debug.Trace + +import HashMap (HashMap) +import HashSet (HashSet) + +import qualified HashMap as HM +import qualified HashSet as HS + + +data HPTState + = HPTState { hptAnalysis :: HeapAnalysis + , hptLiveSet :: HashMap Lhs Env.Rhs + , hptChanged :: !Bool + } +type M = State HPTState + +type Minner a = ReaderT Lhs M a + +type SharingMap = Map.Map Lhs Bool + + +solve :: Equations -> ([HeapAnalysis], HeapAnalysis) +solve eqs + = let iterate i + = do live <- return (reverse $ Map.toList eqs) -- gets (HM.toList . hptLiveSet) + forM_ live $ \(lhs,rhs) -> + do debugMsg $ "Reducing: " ++ ppLhs lhs ++ " " ++ show rhs + reducedRhs <- runReaderT (reduceEqs rhs) lhs + addReduced lhs reducedRhs + --d <- isDead rhs + --when d $ modify $ \st -> st{hptLiveSet = HM.delete lhs (hptLiveSet st)} + return () + bootSequence + = do live <- gets hptLiveSet + forM_ (HM.toList live) $ \(lhs,rhs) -> + do reducedRhs <- runReaderT (reduceEqs rhs) lhs + modify $ \st -> st{ hptAnalysis = hptAddBinding lhs reducedRhs (hptAnalysis st) } + loop iter prev + = case execState (iterate iter) prev of + (newData) -> + if not (hptChanged newData) -- hptAnalysis prev == hptAnalysis newData + then ([hptAnalysis newData], hptAnalysis newData) else + let (iterList, finishedData) = loop (iter+1) newData{hptChanged = False} + in (hptAnalysis newData : iterList, finishedData) + initState = HPTState { hptAnalysis = mkHeapAnalysis (Map.map (const mempty) eqs) (nonlinearVariables eqs) + , hptLiveSet = HM.fromList (Map.toList eqs) + , hptChanged = False } + firstState = execState bootSequence initState + in loop 1 firstState{ hptChanged = False } + +isDead :: Env.Rhs -> M Bool +isDead (Rhs rhs) = do ds <- mapM worker rhs + return (and ds) + where worker Env.Base = return True + worker (Ident i) = do live <- gets hptLiveSet + return (not $ HM.member (VarEntry i) live) + --worker (Env.Heap{}) = return True + worker _ = return False + +-- Scan for shared variables. A variable is shared if it is used more than once. +-- Detecting shared heap points is done later when we solve the equations. +nonlinearVariables :: Equations -> SharingMap +nonlinearVariables eqs + = appEndo (execWriter (mapM_ rhsFn (Map.elems eqs))) Map.empty + where rhsFn (Rhs values) = mapM_ worker values + pushIdent ident = tell $ Endo $ Map.insertWith (\_ _ -> True) (VarEntry ident) False + worker (Extract ident (tag, _nt, _missing) _nth) = pushIdent ident >> pushIdent tag + worker (ExtractVector ident _nth) = pushIdent ident + worker (Eval ident) = pushIdent ident + worker (Update a b) = pushIdent a >> pushIdent b + worker (Apply a b) = pushIdent a >> pushIdent b + worker (PartialApply a b) = return () + worker (Ident ident) = pushIdent ident + worker (Fetch ident) = pushIdent ident + worker Env.Base = return () + worker Env.Heap{} = return () + worker (Tag tag _nt _nargs args) = pushIdent tag >> mapM_ rhsFn args + worker (VectorTag args) = mapM_ rhsFn args + +debugMsg :: Monad m => String -> m () +debugMsg str + = return () -- trace str (return ()) + +ppLhs :: Lhs -> String +ppLhs (VarEntry v) = show (ppRenamed v) +ppLhs (HeapEntry hp) = "@" ++ show hp + + +addReduced :: (MonadState HPTState m) => Lhs -> Interface.Rhs -> m () +addReduced lhs rhs + = do orig <- lookupEqAtomic lhs + let noNewChanges = rhs `Interface.isSubsetOf` orig + unless noNewChanges $ + do modify $ \st -> st{ hptAnalysis = hptAddBinding lhs rhs (hptAnalysis st) } + modify $ \st -> st{ hptChanged = True } + debugMsg $ ppLhs lhs ++ ":" + debugMsg $ "Old: " ++ show orig + debugMsg $ "Rhs: " ++ show rhs + debugMsg $ "New: " ++ show (mappend orig rhs) + --setDirty lhs + shared <- isShared lhs + when shared $ + mapM_ setShared (listHeapPointers rhs) + + +listHeapPointers :: Interface.Rhs -> [HeapPointer] +listHeapPointers (Interface.Heap hps) = Set.toList hps +listHeapPointers _ = [] + + +reduceEqs :: Env.Rhs -> Minner Interface.Rhs +reduceEqs (Rhs rhs) = do rhs' <- mapM reduceEq rhs + return $ mconcat rhs' + +reduceEq :: RhsValue -> Minner Interface.Rhs +reduceEq Env.Base = return $ Interface.Base +reduceEq (Env.Heap hp) = return $ Interface.Heap (Set.singleton hp) +reduceEq (Ident i) = lookupDirtyEq (VarEntry i) +reduceEq (Extract eq node n) = reduceExtract eq node n +reduceEq (ExtractVector eq n) + = do rhs <- lookupEq (VarEntry eq) + case rhs of + Interface.Empty -> return mempty + Interface.Other {rhsVector = args} -> + return (args `nth` n) + where nth [] n = error $ "reduceEq: ExtractVector: " ++ show (eq, n) + nth (x:xs) 0 = x + nth (x:xs) n = nth xs (n-1) +reduceEq (Tag t nt missing args) + = do args' <- mapM reduceEqs args + return $ Other (Map.singleton (t, nt, missing) args') [] +reduceEq (VectorTag args) + = do args' <- mapM reduceEqs args + return $ Interface.Other Map.empty args' +reduceEq (Eval i) = reduceEval i +reduceEq (Fetch i) + = do rhs <- lookupEq (VarEntry i) + case rhs of + Interface.Heap hp -> cautionDirty (VarEntry i) $ liftM mconcat (mapM (lookupEq . HeapEntry) (Set.toList hp)) + Empty -> return Empty +reduceEq (Apply a b) = reduceApply a b +reduceEq (PartialApply a b) + = do rhs <- lookupEq (VarEntry a) + case rhs of + Empty -> return Empty + Other{rhsTagged = nodes} -> + do let f ((tag, nt, n), args) + | n == 0 = return mempty + | otherwise = do bRhs <- lookupDirtyEq (VarEntry b) + return $ Other (Map.singleton (tag, nt, (n-1)) (args ++ [bRhs])) [] + cautionDirty (VarEntry a) $ liftM mconcat $ mapM f (Map.toList nodes) +reduceEq (Update hp val) + = do rhs <- lookupEq (VarEntry hp) + case rhs of + Interface.Empty -> return mempty + Interface.Heap hps -> + do valRhs <- cautionDirty (VarEntry hp) $ lookupDirtyEq (VarEntry val) + forM_ (Set.toList hps) $ \hp -> addReduced (HeapEntry hp) valRhs + return mempty + +reduceExtract eq node n + = do rhs <- lookupEq (VarEntry eq) + case rhs of + Interface.Empty -> return mempty + Other{rhsTagged = nodes} -> + return (Map.findWithDefault [] node nodes `nth` n) + where nth [] n = mempty + nth (x:xs) 0 = x + nth (x:xs) n = nth xs (n-1) + +reduceEval i + = do hpt <- gets hptAnalysis + rhs <- lookupEq (VarEntry i) + case rhs of + Interface.Base -> return Interface.Base + Interface.Empty -> return Interface.Empty + Interface.Heap hps -> + do let anyShared = heapIsShared i hpt + let fn hp = do let worker ((t, FunctionNode, 0), args) = do rhs <- lookupDirtyEq (VarEntry t) + when (anyShared && rhs /= mempty) $ + addReduced (HeapEntry hp) rhs + return rhs + worker ((t, nt, missing), args) = return $ Other (Map.singleton (t, nt, missing) args) [] + hpRhs <- lookupEq (HeapEntry hp) + case hpRhs of + Empty -> return mempty + Other{rhsTagged = nodes} -> liftM mconcat $ mapM worker (Map.toList nodes) + cautionDirty (VarEntry i) $ liftM mconcat $ mapM fn (Set.toList hps) + rhs -> error $ "Eval: " ++ show (rhs, i) + +reduceApply a b + = do rhs <- lookupEq (VarEntry a) + case rhs of + Empty -> return Empty + Other{rhsTagged = nodes} -> + do let f ((func, FunctionNode, 1), args) + = lookupDirtyEq (VarEntry func) + f ((conc, nt, n), args) + | n == 0 = return mempty + | otherwise = do bRhs <- lookupDirtyEq (VarEntry b) + return $ Other (Map.singleton (conc, nt, (n-1)) (args ++ [bRhs])) [] + cautionDirty (VarEntry a) $ liftM mconcat $ mapM f (Map.toList nodes) + + +lookupDirtyEq :: Lhs -> Minner Interface.Rhs +lookupDirtyEq lhs = lookupEq lhs +{- +lookupDirtyEq lhs + = do isClean <- gets (HS.member lhs . hptClean) + allDirty <- gets ((/=) 0 . hptAllDirty) + if isClean && not allDirty + then return Empty + else lookupEq lhs +-} + +lookupEq :: Lhs -> Minner Interface.Rhs +lookupEq lhs + = do --addDependency lhs + gets $ \st -> lookupLhs lhs (hptAnalysis st) + +cautionDirty :: Lhs -> Minner a -> Minner a +cautionDirty _ action = action +{- +cautionDirty lhs action + = do isClean <- gets (HS.member lhs . hptClean) + if isClean then action else + do modify $ \st -> st{hptAllDirty = succ (hptAllDirty st) } + r <- action + modify $ \st -> st{hptAllDirty = pred (hptAllDirty st) } + return r +-} + +lookupEqAtomic :: MonadState HPTState m => Lhs -> m Interface.Rhs +lookupEqAtomic lhs + = gets $ \st -> lookupLhs lhs (hptAnalysis st) + +isShared :: MonadState HPTState m => Lhs -> m Bool +isShared lhs + = gets $ \st -> hptIsShared lhs (hptAnalysis st) + +setShared :: MonadState HPTState m => HeapPointer ->m () +setShared hp = modify $ \st ->st{hptAnalysis = hptSetShared (HeapEntry hp) (hptAnalysis st)} + + diff --git a/src/Grin/HPT/Interface.hs b/src/Grin/HPT/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Grin/HPT/Interface.hs @@ -0,0 +1,196 @@ +module Grin.HPT.Interface + ( HeapAnalysis + , Node + , IsShared + , Rhs(..) + , isSubsetOf + , mkHeapAnalysis + , lookupHeap + , lookupLhs + , heapIsShared + , hptIsShared + , hptSetShared + , hptAddBinding + , rhsSize + ) where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Grin.Types ( Renamed(..), NodeType, uniqueId ) +import Grin.HPT.Environment ( HeapPointer, Lhs(..), Node ) + +import Data.Monoid + +import Grin.Stage2.Pretty (ppNodeType) +import Text.PrettyPrint.ANSI.Leijen + +import Control.Parallel.Strategies + +import qualified HashMap as HT + +type IsShared = Bool + +data Rhs + = Empty + | Base + | Heap (Set.Set HeapPointer) + | Other { rhsTagged :: (Map.Map Node [Rhs]) + , rhsVector :: [Rhs] } +-- , rhsHeap :: Set.Set HeapPointer } +-- | Tagged (Map.Map Node [Rhs]) +-- | Vector [Rhs] +-- | Heap (Set.Set HeapPointer) + deriving (Eq) + +instance NFData Rhs where + rnf Empty = () + rnf Base = () + rnf (Heap h) = rnf h + rnf (Other t v) = if False -- not (Map.null t && null v) && not (Set.null h) + then error "Broken invariant." + else rnf t `seq` rnf v -- `seq` rnf h + +instance NFData Renamed where + rnf _ = () +instance NFData NodeType where + rnf _ = () + +instance Show Rhs where + showsPrec _ = displayS . renderPretty 1 200 . ppRhs + +ppRhs Empty = text "Empty" +ppRhs Base = text "Base" +ppRhs (Heap hps) = text "Heap" <+> list (map int (Set.toList hps)) +ppRhs (Other nodes args) + = text "Other" <+> list [ (ppNodeType nt missing tag) <+> list (map ppRhs args) | ((tag, nt, missing), args) <- Map.toList nodes ] + <+> list (map ppRhs args) +-- <+> list (map int (Set.toList hps)) +--ppRhs (Tagged nodes) = +--ppRhs (Vector args) = +--ppRhs (Heap hps) = + +instance Monoid Rhs where + mempty = Empty + mappend = joinRhs + +joinRhs :: Rhs -> Rhs -> Rhs +joinRhs Empty rhs = rhs +joinRhs rhs Empty = rhs +joinRhs Base Base = Base +joinRhs (Heap h1) (Heap h2) = Heap (Set.union h1 h2) +joinRhs (Other t1 v1) (Other t2 v2) +-- | Map.size t1 `seq` Map.size t2 `seq` False = undefined +-- | Set.size h1 `seq` Set.size h2 `seq` False = undefined + | otherwise = Other (Map.unionWith zipJoin t1 t2) (zipJoin v1 v2) -- (Set.union h1 h2) +joinRhs rhs Base = rhs +joinRhs Base rhs = rhs +{- +joinRhs (Tagged nodes1) (Tagged nodes2) = Tagged (Map.unionWith zipJoin nodes1 nodes2) +joinRhs (Vector args1) (Vector args2) = Vector (zipJoin args1 args2) +joinRhs (Heap hp1) (Heap hp2) = Heap (Set.union hp1 hp2) +joinRhs left right = error $ "Unmatched rhs values: " ++ show (left,right) +-} + +isSubsetOf :: Rhs -> Rhs -> Bool +lRhs `isSubsetOf` rRhs + = worker lRhs rRhs + where worker Empty y = True + worker x Empty = False + worker _ Base = True + worker Base _ = False + worker (Heap h1) (Heap h2) = Set.isSubsetOf h1 h2 + worker (Other t1 v1) (Other t2 v2) + = Map.isSubmapOfBy (\a b -> and (zipWith isSubsetOf a b)) t1 t2 && + and (zipWith isSubsetOf v1 v2) +-- && Set.isSubsetOf h1 h2 +{- + worker (Tagged nodes1) (Tagged nodes2) + = Map.isSubmapOfBy (\a b -> and (zipWith isSubsetOf a b)) nodes1 nodes2 + worker (Vector args1) (Vector args2) + = and (zipWith isSubsetOf args1 args2) + worker (Heap hp1) (Heap hp2) + = Set.isSubsetOf hp1 hp2 + worker Base Base = True + worker _ _ = False -- should be an error. +-} + + +zipJoin :: Monoid a => [a] -> [a] -> [a] +zipJoin [] [] = [] +zipJoin [] lst = zipWith mappend (repeat mempty) lst +zipJoin lst [] = zipWith mappend lst (repeat mempty) +zipJoin (x:xs) (y:ys) = mappend x y : zipJoin xs ys + + +instance HT.Hashable Lhs where + hash (VarEntry var) = HT.hash var + hash (HeapEntry hp) = hp + +data HeapAnalysis + = HeapAnalysis { hptBindings :: HT.HashMap Lhs Rhs + , hptSharingMap :: Map.Map Lhs IsShared + } + deriving (Eq) + +instance Show HeapAnalysis where + show (HeapAnalysis binds smap) = unlines ([ unlines [ show lhs, " " ++ show rhs] | (lhs,rhs) <- HT.toList binds ]) + +--instance NFData HeapAnalysis where +-- rnf hpt = rnf (hptBindings hpt) `seq` rnf (hptSharingMap hpt) + +mkHeapAnalysis :: Map.Map Lhs Rhs -> Map.Map Lhs IsShared -> HeapAnalysis +mkHeapAnalysis binds smap + = HeapAnalysis { hptBindings = HT.fromList (Map.toList binds) + , hptSharingMap = smap + } + +lookupLhs :: Lhs -> HeapAnalysis -> Rhs +lookupLhs lhs hpt + = HT.findWithDefault Empty lhs (hptBindings hpt) + + +rhsSize :: Rhs -> Int +rhsSize Empty = 0 +rhsSize Base = 1 +rhsSize (Heap hp) = 1 +rhsSize (Other t v) + = maximum [ (1 + maximum (0:map length (Map.elems t))) + , length v ] +{- +rhsSize (Tagged nodes) = 1 + maximum (0:map length (Map.elems nodes)) +rhsSize (Vector args) = length args +rhsSize Heap{} = 1 +-} + +lookupHeap :: Renamed -> HeapAnalysis -> Rhs +lookupHeap var hpt + = case HT.lookup (VarEntry var) (hptBindings hpt) of + Just (Heap hp) -> mconcat [ HT.findWithDefault (errMsg pointer) (HeapEntry pointer) (hptBindings hpt) | pointer <- Set.toList hp ] + Just Empty -> Empty + Just rhs -> error $ "Grin.HPT.Interface.lookupHeap: Invalid rhs: " ++ show (var, rhs) + Nothing -> error $ "Grin.HPT.Interface.lookupHeap: Couldn't find lhs: " ++ show var + where errMsg p = error $ "Grin.HPT.Interface.lookupHeap: Heap value not found: " ++ show p + +heapIsShared :: Renamed -> HeapAnalysis -> IsShared +heapIsShared var hpt + = case HT.lookup (VarEntry var) (hptBindings hpt) of + Just (Heap hp) -> or [ Map.findWithDefault False (HeapEntry pointer) (hptSharingMap hpt) | pointer <- Set.toList hp ] + Just Empty -> False + Just rhs -> error $ "Grin.HPT.Interface.heapIsShared: Invalid rhs: " ++ show (var, rhs) + Nothing -> error $ "Grin.HPT.Interface.heapIsShared: Couldn't find lhs: " ++ show var + +hptIsShared :: Lhs -> HeapAnalysis -> IsShared +hptIsShared lhs hpt + = Map.findWithDefault False lhs (hptSharingMap hpt) + +hptSetShared :: Lhs -> HeapAnalysis -> HeapAnalysis +hptSetShared lhs hpt + = hpt { hptSharingMap = Map.insert lhs True (hptSharingMap hpt) } + +hptAddBinding :: Lhs -> Rhs -> HeapAnalysis -> HeapAnalysis +hptAddBinding lhs rhs hpt + = case HT.lookup lhs (hptBindings hpt) of + Nothing -> hpt { hptBindings = HT.insert lhs rhs (hptBindings hpt) } + Just old -> let joined = old `mappend` rhs + in rnf joined `seq` hpt { hptBindings = HT.insert lhs joined (hptBindings hpt) } + diff --git a/src/Grin/HPT/Lower.hs b/src/Grin/HPT/Lower.hs --- a/src/Grin/HPT/Lower.hs +++ b/src/Grin/HPT/Lower.hs @@ -3,24 +3,26 @@ ( lower ) where -import Grin.Types +import Grin.Types as Grin import qualified Data.Map as Map +import qualified Data.Set as Set import Control.Monad.State -import Control.Monad.Reader import Control.Monad.Writer +import Data.List (delete) -import Grin.HPT.Environment -import Grin.HPT.Solve +import Grin.HPT.Environment (Lhs(..)) +import Grin.HPT.Interface as Interface -type M a = ReaderT HeapAnalysis (State Int) a +type M a = State (HeapAnalysis, Int) a -lower :: HeapAnalysis -> Grin -> Grin +lower :: HeapAnalysis -> Grin -> (Grin, HeapAnalysis) lower hpt grin - = evalState (runReaderT worker hpt) (grinUnique grin) + = case runState worker (hpt, grinUnique grin) of + (grin, (hpt',_newUnique)) -> (grin, hpt') where worker = do fns <- mapM lowerFuncDef (grinFunctions grin) - unique <- get + unique <- gets snd return grin{ grinFunctions = fns , grinUnique = unique } @@ -40,27 +42,38 @@ return $ a' :>> b' lowerExpression (Application (Builtin "eval") [a]) = do f <- newVariable - HeapAnalysis hpt <- ask - case Map.lookup (VarEntry a) hpt of - Just (Rhs rhs) -> do let Rhs rhs' = mconcat [ hpt Map.! HeapEntry hp | Heap hp <- rhs ] - alts <- mapM (mkApplyAlt []) rhs' - v <- newVariable - u <- mkUpdate a f v rhs' - return $ Application (Builtin "fetch") [a] :>>= f :-> - Case f alts :>>= v :-> - u :>> -- Application (Builtin "update") [a,v] :>> - Unit (Variable v) - Nothing -> return $ Application (Builtin "urk") [] + hpt <- gets fst + case lookupHeap a hpt of + Interface.Empty -> return $ Application (Builtin "unreachable") [] + rhs@Other{rhsTagged = nodes} + -> do let tags = Map.toList nodes + addHPTInfo (VarEntry f) rhs -- (Tagged nodes) + alts <- mapM (mkApplyAlt []) tags + v <- newVariable + let expand ((tag,FunctionNode,0),_args) = lookupLhs (VarEntry tag) hpt + expand (node,args) = Other (Map.singleton node args) [] + expanded = mconcat $ map expand tags + addHPTInfo (VarEntry v) expanded + let anyShared = heapIsShared a hpt + u <- mkUpdate anyShared a f v tags expanded + return $ Application (Builtin "fetch") [a] :>>= f :-> + Case f alts :>>= v :-> + u :>> + Unit (Variable v) lowerExpression (Application (Builtin "apply") [a,b]) - = do HeapAnalysis hpt <- ask - case Map.lookup (VarEntry a) hpt of - Just (Rhs rhs) -> do alts <- mapM (mkApplyAlt [b]) rhs - return $ Case a alts - Nothing -> return $ Application (Builtin "urk") [] + = do hpt <- gets fst + case lookupLhs (VarEntry a) hpt of + Other{rhsTagged = nodes} -> do alts <- mapM (mkApplyAlt [b]) (Map.toList nodes) + return $ Case a alts + Interface.Empty -> return $ Application (Builtin "unreachable") [] lowerExpression (Application fn args) = return $ Application fn args +lowerExpression (Update size ptr val) + = return $ Update size ptr val lowerExpression (Case scrut alts) - = do alts' <- mapM lowerAlt alts + = do hpt <- gets fst + let rhs = lookupLhs (VarEntry scrut) hpt + alts' <- mapM lowerAlt (filter (`isMemberOf` rhs) alts) return $ Case scrut alts' lowerExpression (Store val) = return $ Store val @@ -76,28 +89,52 @@ = do b' <- lowerExpression b return $ a :> b' -mkUpdate :: Renamed -> Renamed -> Renamed ->[RhsValue] -> M Expression -mkUpdate ptr scrut val tags - = do fnTags <- sequence [ do args' <- replicateM (length args) newVariable - return $ Node tag FunctionNode n args' | t@(Tag tag FunctionNode n args) <- tags, n == 0 ] - constrTags <- sequence [ do args' <- replicateM (length args) newVariable - return $ Node tag nt n args' | t@(Tag tag nt n args) <- tags, not (n == 0 && nt == FunctionNode) ] - let doUpdate = Case val [ tag :> Application (Builtin "update") [ptr,val] | tag <- constrTags ] - if null fnTags || null constrTags - then return $ Unit Empty - else return $ doUpdate +(Node tag nt missing args :> _) `isMemberOf` (Other{rhsTagged = nodes}) + = (tag, nt, missing) `Map.member` nodes +_ `isMemberOf` rhs = True -mkApplyAlt :: [Renamed] -> RhsValue -> M Alt -mkApplyAlt extraArgs (Tag tag FunctionNode n argsRhs) | n == length extraArgs + +mkUpdate :: Bool -> Renamed -> Renamed -> Renamed ->[(Node, [Rhs])] -> Rhs -> M Expression +mkUpdate False ptr scrut val tags _ = return $ Unit Grin.Empty +mkUpdate shared ptr scrut val tags _ -- (Other{rhsTagged = expanded}) + = do hpt <- gets fst + let doUpdate tag = case lookupLhs (VarEntry tag) hpt of + Other{rhsTagged = expanded} -> do alts <- mapM (uWorker val) (Map.toList expanded) + return $ Case val alts + _ -> return $ Unit Grin.Empty + uWorker val ((tag, nt, missing), args) + = do args' <- replicateM (length args) newVariable + node <- newVariable + addHPTInfo (VarEntry node) (Other (Map.singleton (tag, nt, missing) args) []) + return (Node tag nt missing args' :> Update (length args'+1) ptr val) + let worker ((tag, FunctionNode, 0), args) + = do args' <- replicateM (length args) newVariable + u <- doUpdate tag + return $ Node tag FunctionNode 0 args' :> u + worker ((tag, nt, missingArgs), args) + = do args' <- replicateM (length args) newVariable + return $ Node tag nt missingArgs args' :> Unit Grin.Empty + alts' <- mapM worker tags + return $ Case scrut alts' +mkUpdate shared ptr scrut val tags _ = return $ Unit Grin.Empty + +mkApplyAlt :: [Renamed] -> (Node, [Rhs]) -> M Alt +mkApplyAlt extraArgs ((tag, FunctionNode, n), argsRhs) | n == length extraArgs = do args <- replicateM (length argsRhs) newVariable return $ Node tag FunctionNode n args :> Application tag (args ++ extraArgs) -mkApplyAlt extraArgs (Tag tag nt n argsRhs) +mkApplyAlt [extraArg] ((tag, nt, 0), argsRhs) + = return $ Node tag nt 0 [] :> Application (Builtin "unreachable") [] +mkApplyAlt extraArgs ((tag, nt, n), argsRhs) = do args <- replicateM (length argsRhs) newVariable return $ Node tag nt n args :> Unit (Node tag nt (n - length extraArgs) (args ++ extraArgs)) -mkApplyAlt _ val = error $ "Grin.HPT.Lower.mkApplyAlt: expected tag: " ++ show val +mkApplyAlt _ val = error $ "Grin.HPT.Lower.mkApplyAlt: unexpected tag: " ++ show val +addHPTInfo :: Lhs -> Rhs -> M () +addHPTInfo lhs rhs + = modify $ \(hpt, unique) -> (hptAddBinding lhs rhs hpt, unique) + newVariable :: M Renamed -newVariable = do unique <- get - put (unique + 1) +newVariable = do unique <- gets snd + modify $ \st -> (fst st, unique + 1) return $ Anonymous unique diff --git a/src/Grin/HPT/QuickSolve.hs b/src/Grin/HPT/QuickSolve.hs new file mode 100644 --- /dev/null +++ b/src/Grin/HPT/QuickSolve.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE OverloadedStrings #-} +module Grin.HPT.QuickSolve + ( solve + ) where + +import Grin.Types ( Renamed(..), NodeType(..) ) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State.Strict + +import Grin.HPT.Environment as Env +import Grin.HPT.Interface as Interface +import qualified Grin.HPT.Interface as Interface + +import Grin.Stage2.Pretty (ppRenamed) + +--import Tick +import Debug.Trace + +import Control.Parallel.Strategies + +type M a = State HeapAnalysis a + +type SharingMap = Map.Map Lhs Bool + + +solve :: Equations -> ([HeapAnalysis], HeapAnalysis) +solve eqs + = let eqPairs = Map.toList eqs + iterate i ls + = forM_ ls $ \(lhs,rhs) -> + do debugMsg $ "Reducing: " ++ ppLhs lhs ++ " " ++ show i + reducedRhs <- reduceEqs rhs + addReduced lhs reducedRhs + loop iter prev + = case execState (debugMsg ("Iteration: " ++ show iter) >> iterate iter eqPairs) prev of + (newData) -> -- | rnf newData `seq` True -> + let (iterList, finishedData) = if prev == newData then ([newData], newData) else loop (iter+1) newData + in (newData : iterList, finishedData) + in loop 1 (mkHeapAnalysis (Map.map (const mempty) eqs) (nonlinearVariables eqs)) + +-- Scan for shared variables. A variable is shared if it is used more than once. +-- Detecting shared heap points is done later when we solve the equations. +nonlinearVariables :: Equations -> SharingMap +nonlinearVariables eqs + = appEndo (execWriter (mapM_ rhsFn (Map.elems eqs))) Map.empty + where rhsFn (Rhs values) = mapM_ worker values + pushIdent ident = tell $ Endo $ Map.insertWith (\_ _ -> True) (VarEntry ident) False + worker (Extract ident (tag, _nt, _missing) _nth) = pushIdent ident >> pushIdent tag + worker (ExtractVector ident _nth) = pushIdent ident + worker (Eval ident) = pushIdent ident + worker (Update a b) = pushIdent a >> pushIdent b + worker (Apply a b) = pushIdent a >> pushIdent b + worker (PartialApply a b) = return () + worker (Ident ident) = pushIdent ident + worker (Fetch ident) = pushIdent ident + worker Env.Base = return () + worker Env.Heap{} = return () + worker (Tag tag _nt _nargs args) = pushIdent tag >> mapM_ rhsFn args + worker (VectorTag args) = mapM_ rhsFn args + +debugMsg :: String -> M () +debugMsg str + = return () -- trace str (return ()) + +ppLhs :: Lhs -> String +ppLhs (VarEntry v) = show (ppRenamed v) +ppLhs (HeapEntry hp) = "@" ++ show hp + + +addReduced :: Lhs -> Interface.Rhs -> M () +addReduced lhs rhs + = do orig <- {-addTick "AddReduced" $ -} lookupEq lhs + let noNewChanges = rhs `Interface.isSubsetOf` orig + unless noNewChanges $ + do {-addTick "HPT: Change" $ -} + modify $ \hpt -> hptAddBinding lhs rhs hpt + debugMsg $ ppLhs lhs ++ ":" + --debugMsg $ "Old: " ++ show orig + --debugMsg $ "Rhs: " ++ show rhs + debugMsg $ "New: " ++ show (mappend orig rhs) + shared <- isShared lhs + when shared $ + mapM_ setShared (listHeapPointers rhs) + +listHeapPointers :: Interface.Rhs -> [HeapPointer] +listHeapPointers (Interface.Heap hps) = Set.toList hps +listHeapPointers _ = [] + + +reduceEqs :: Env.Rhs -> M Interface.Rhs +reduceEqs (Rhs rhs) = do rhs' <- mapM reduceEq rhs + return $ mconcat rhs' + +reduceEq :: RhsValue -> M Interface.Rhs +reduceEq Env.Base = return $ Interface.Base +reduceEq (Env.Heap hp) = return $ Interface.Heap (Set.singleton hp) +reduceEq (Ident i) = lookupEq (VarEntry i) +reduceEq (Extract eq node n) = reduceExtract eq node n +reduceEq (ExtractVector eq n) + = do rhs <- lookupEq (VarEntry eq) + case rhs of + Interface.Empty -> return mempty + Interface.Other {rhsVector = args} -> + return (args `nth` n) + where nth [] n = error $ "reduceEq: ExtractVector: " ++ show (eq, n) + nth (x:xs) 0 = x + nth (x:xs) n = nth xs (n-1) +reduceEq (Tag t nt missing args) + = do args' <- mapM reduceEqs args + return $ Other (Map.singleton (t, nt, missing) args') [] +reduceEq (VectorTag args) + = do args' <- mapM reduceEqs args + return $ Interface.Other Map.empty args' +reduceEq (Eval i) = reduceEval i +reduceEq (Fetch i) + = do hpt <- get + return $ lookupHeap i hpt +reduceEq (Apply a b) = reduceApply a b +reduceEq (PartialApply a b) + = do rhs <- lookupEq (VarEntry a) + case rhs of + Empty -> return Empty + Other{rhsTagged = nodes} -> + do let f ((tag, nt, n), args) + | n == 0 = return mempty + | otherwise = do bRhs <- lookupEq (VarEntry b) + return $ Other (Map.singleton (tag, nt, (n-1)) (args ++ [bRhs])) [] + f t = error $ "reduceEq: apply: " ++ show t + liftM mconcat $ mapM f (Map.toList nodes) +reduceEq (Update hp val) + = do rhs <- lookupEq (VarEntry hp) + case rhs of + Interface.Empty -> return mempty + Interface.Heap hps -> + do valRhs <- lookupEq (VarEntry val) + forM_ (Set.toList hps) $ \hp -> addReduced (HeapEntry hp) valRhs + return mempty + +reduceExtract eq node n + = do rhs <- lookupEq (VarEntry eq) + case rhs of + Interface.Empty -> return mempty + Other{rhsTagged = nodes} -> + return (Map.findWithDefault [] node nodes `nth` n) + where nth [] n = mempty + nth (x:xs) 0 = x + nth (x:xs) n = nth xs (n-1) + +reduceEval i + = do hpt <- get + case lookupLhs (VarEntry i) hpt of + Interface.Base -> return Interface.Base + Interface.Empty -> return Interface.Empty + Interface.Heap hps -> + do let anyShared = heapIsShared i hpt + let fn hp = do let worker ((t, FunctionNode, 0), args) = do rhs <- lookupEq (VarEntry t) + when (anyShared && rhs /= mempty) $ + addReduced (HeapEntry hp) rhs + return rhs + worker ((t, nt, missing), args) = return $ Other (Map.singleton (t, nt, missing) args) [] + case lookupLhs (HeapEntry hp) hpt of + Empty -> return mempty + Other{rhsTagged = nodes} -> liftM mconcat $ mapM worker (Map.toList nodes) + liftM mconcat $ mapM fn (Set.toList hps) + rhs -> error $ "Eval: " ++ show (rhs, i) + +reduceApply a b + = do rhs <- lookupEq (VarEntry a) + case rhs of + Empty -> return Empty + Other{rhsTagged = nodes} -> + do let f ((func, FunctionNode, 1), args) + = reduceEq (Ident func) + f ((conc, nt, n), args) + | n == 0 = return mempty + | otherwise = do bRhs <- lookupEq (VarEntry b) + return $ Other (Map.singleton (conc, nt, (n-1)) (args ++ [bRhs])) [] + liftM mconcat $ mapM f (Map.toList nodes) + + + +-- FIXME: Throw an exception if 'lhs' couldn't be found. +lookupEq :: Lhs -> M Interface.Rhs +lookupEq lhs + = gets $ \(hpt) -> lookupLhs lhs hpt + +-- FIXME: Throw an exception if 'lhs' couldn't be found. +isShared :: Lhs -> M Bool +isShared lhs + = gets $ \(hpt) -> hptIsShared lhs hpt + +setShared :: HeapPointer -> M () +setShared hp = modify $ \hpt -> hptSetShared (HeapEntry hp) hpt + +{- +lhsIsDead :: Lhs -> M Bool +lhsIsDead lhs + = asks $ \(_hpt, dead) -> lhs `Set.member` dead + +lhsSetDead :: Lhs -> M () +lhsSetDead lhs + = tell (mempty, Endo $ Set.insert lhs) +-} diff --git a/src/Grin/HPT/Solve.hs b/src/Grin/HPT/Solve.hs --- a/src/Grin/HPT/Solve.hs +++ b/src/Grin/HPT/Solve.hs @@ -1,54 +1,104 @@ {-# LANGUAGE OverloadedStrings #-} module Grin.HPT.Solve - ( HeapAnalysis(..) - , solve + ( solve ) where import Grin.Types import qualified Data.Map as Map +import qualified Data.Set as Set import Control.Monad.Reader import Control.Monad.Writer ---import System.IO ---import System.IO.Unsafe - import Grin.HPT.Environment +import qualified Grin.HPT.Interface as Interface data HeapAnalysis - = HeapAnalysis (Map.Map Lhs Rhs) + = HeapAnalysis (Map.Map Lhs Rhs) SharingMap +instance Show HeapAnalysis where + show (HeapAnalysis eqs _sharingMap) + = unlines [ show lhs ++ " = " ++ show rhs | (lhs,rhs) <- Map.toList eqs ] -type M a = ReaderT Equations (Writer (Endo Equations)) a +type SharingMap = Map.Map Lhs Bool +type M a = ReaderT (Equations,SharingMap) (Writer (Endo Equations, Endo SharingMap)) a -solve :: Equations -> (Int, HeapAnalysis) + +dataOne = singleton (Tag (Anonymous 2) ConstructorNode 0 [arg]) +arg = singleton (Tag (Anonymous 3) ConstructorNode 0 []) +testEqs = Map.fromList [(VarEntry (Anonymous 1), dataOne) + ,(VarEntry (Anonymous 4), singleton (Ident (Anonymous 1))) + ,(VarEntry (Anonymous 5), singleton (Ident (Anonymous 4))) + ,(VarEntry (Anonymous 6), singleton (Ident (Anonymous 4)))] + +mkInterface :: HeapAnalysis -> Interface.HeapAnalysis +mkInterface (HeapAnalysis binds smap) + = Interface.mkHeapAnalysis (Map.map fromRhs binds) smap + where fromRhs (Rhs vals) = mconcat (map toRhs vals) + toRhs Base = Interface.Base + toRhs (Heap hp) = Interface.Other Map.empty [] (Set.singleton hp) + toRhs (Tag node nt missing args) = Interface.Other (Map.singleton (node,nt,missing) (map fromRhs args)) [] Set.empty + toRhs (VectorTag rhs) = Interface.Other Map.empty (map fromRhs rhs) Set.empty + toRhs rhs = error $ "Grin.HPT.Solve.mkInterface: bad rhs: " ++ show rhs + +solve :: Equations -> (Int, Interface.HeapAnalysis) solve eqs + = case solve' eqs of + (iterations, hpt) -> (iterations, mkInterface hpt) + +solve' :: Equations -> (Int, HeapAnalysis) +solve' eqs = let iterate ls = forM_ ls $ \(lhs,rhs) -> do reducedRhs <- reduceEqs rhs addReduced lhs reducedRhs - loop iter prev - = case {-traceOut ("\nIteration: " ++ show iter ++ "\n") $-} (execWriter (runReaderT (iterate (Map.toList eqs)) prev)) of - newDefs -> - let next = (Map.unionWith mappend prev (appEndo newDefs Map.empty)) - in if prev == next then (iter, HeapAnalysis next) else loop (iter+1) next - in loop 1 (Map.map (const mempty) eqs) - ---traceOut str v = unsafePerformIO (putStr str) `seq` v - + loop iter shared prev + = case execWriter (runReaderT (iterate (Map.toList eqs)) (prev, shared)) of + (newDefs, newShared) -> + let next = appEndo newDefs prev + nextShared = appEndo newShared shared + in if prev == next then (iter, HeapAnalysis next nextShared) else loop (iter+1) nextShared next + in loop 1 (nonlinearVariables eqs) (Map.map (const mempty) eqs) -isSubsetOf :: (Monoid a, Eq a) => a -> a -> Bool -a `isSubsetOf` b = b == (a `mappend` b) +-- Scan for shared variables. A variable is shared if it is used more than once. +-- Detecting shared heap points is done later when we solve the equations. +nonlinearVariables :: Equations -> SharingMap +nonlinearVariables eqs + = appEndo (execWriter (mapM_ rhsFn (Map.elems eqs))) Map.empty + where rhsFn (Rhs values) = mapM_ worker values + pushIdent ident = tell $ Endo $ Map.insertWith (\_ _ -> True) (VarEntry ident) False + worker (Extract ident (tag, _nt, _missing) _nth) = pushIdent ident >> pushIdent tag + worker (ExtractVector ident _nth) = pushIdent ident + worker (Eval ident) = pushIdent ident + worker (Update a b) = pushIdent a >> pushIdent b + worker (Apply a b) = pushIdent a >> pushIdent b + worker (PartialApply a b) = return () + worker (Ident ident) = pushIdent ident + worker (Fetch ident) = pushIdent ident + worker Base = return () + worker Heap{} = return () + worker (Tag tag _nt _nargs args) = pushIdent tag >> mapM_ rhsFn args + worker (VectorTag args) = mapM_ rhsFn args addReduced :: Lhs -> Rhs -> M () addReduced lhs rhs = do orig <- lookupEq lhs - {-let isNew = not (rhs `isSubsetOf` orig) - tag = if isNew then "+" else "-" - traceOut tag $-} - unless (rhs `isSubsetOf` orig) $ tell $ Endo $ Map.insertWith mappend lhs rhs + unless (rhs `isSubsetOf` orig) $ + do tell (Endo $ Map.insertWith mappend lhs rhs, mempty) + shared <- isShared lhs + when shared $ + mapM_ setShared (listHeapPointers rhs) +listHeapPointers :: Rhs -> [HeapPointer] +listHeapPointers rhs = workerRhs rhs [] + where workerRhs (Rhs values) = flip (foldr worker) values + worker (Heap hp) = (hp:) + worker (Tag _tag _nt _nargs args) = flip (foldr workerRhs) args + worker (VectorTag args) = flip (foldr workerRhs) args + worker _ = id + + reduceEqs :: Rhs -> M Rhs reduceEqs (Rhs rhs) = do rhs' <- mapM reduceEq rhs return $ mconcat rhs' @@ -57,71 +107,78 @@ reduceEq Base = return $ singleton Base reduceEq (Heap hp) = return $ singleton $ Heap hp reduceEq (Ident i) = lookupEq (VarEntry i) -reduceEq (Extract eq tag n) +reduceEq (Extract eq (tag, _nt, _missing) n) = do Rhs eqs' <- lookupEq (VarEntry eq) - reduceEqs (mconcat [ args `nth` n | Tag t _ _ args <- eqs', t == tag ]) + return ({-# SCC "Extract.mappend" #-} mconcat [ args `nth` n | Tag t _ _ args <- eqs', t == tag ]) where nth [] n = mempty --error $ "reduceEq: ExtractVector: " ++ show (eqs, tag, n) nth (x:xs) 0 = x nth (x:xs) n = nth xs (n-1) reduceEq (ExtractVector eq n) = do Rhs eqs' <- lookupEq (VarEntry eq) - reduceEqs (mconcat [ args `nth` n | VectorTag args <- eqs' ]) + return ({-# SCC "ExtractVector.mappend" #-} mconcat [ args `nth` n | VectorTag args <- eqs' ]) where nth [] n = error $ "reduceEq: ExtractVector: " ++ show (eq, n) nth (x:xs) 0 = x nth (x:xs) n = nth xs (n-1) -{- -reduceEq (Tag fn FunctionNode 0 args) - = do args' <- mapM reduceEqs args - rets <- lookupEq (VarEntry fn) - return $ singleton (Tag fn FunctionNode 0 args') `mappend` rets --} reduceEq (Tag t nt missing args) - = do --args' <- mapM reduceEqs args - return $ singleton (Tag t nt missing args) + = do args' <- mapM reduceEqs args + return $ singleton (Tag t nt missing args') reduceEq (VectorTag args) = do args' <- mapM reduceEqs args return $ singleton (VectorTag args') reduceEq (Eval i) = do Rhs vals <- lookupEq (VarEntry i) - let f (Heap hp) = do Rhs rhs <- lookupEq (HeapEntry hp) - let worker (Tag fn FunctionNode 0 _) = lookupEq (VarEntry fn) - worker other = return $ singleton other - rets <- liftM mconcat $ mapM worker rhs - addReduced (HeapEntry hp) rets - return rets - f t = error $ "reduceEq: eval: " ++ show (t,i,vals) - liftM mconcat $ mapM f vals + let unHeap (Heap hp) = hp + unHeap t = error $ "reduceEq: eval: " ++ show (t,i,vals) + hps = map unHeap vals + anyShared <- liftM or $ mapM (isShared . HeapEntry) hps + let fn hp = do Rhs rhs <- lookupEq (HeapEntry hp) + let worker (Tag fn FunctionNode 0 _) = do rhs <- lookupEq (VarEntry fn) + when (anyShared && rhs /= mempty) $ + addReduced (HeapEntry hp) rhs + return rhs + worker other = return $ singleton other + {-# SCC "Eval.mappend2" #-} liftM mconcat $ mapM worker rhs + {-# SCC "Eval.mappend" #-} liftM mconcat $ mapM fn hps reduceEq (Fetch i) = do Rhs vals <- lookupEq (VarEntry i) let f (Heap hp) = lookupEq (HeapEntry hp) f Base = return mempty f t = error $ "reduceEq: fetch: " ++ show (t,i,vals) - liftM mconcat $ mapM f vals + {-# SCC "Fetch.mappend" #-} liftM mconcat $ mapM f vals reduceEq (Apply a b) = do Rhs vals <- lookupEq (VarEntry a) let f (Tag func FunctionNode 1 args) = reduceEq (Ident func) f (Tag conc nt n args) | n == 0 = return mempty - | otherwise = return $ singleton (Tag conc nt (n-1) (args ++ [singleton (Ident b)])) + | otherwise = do bRhs <- lookupEq (VarEntry b) + return $ singleton (Tag conc nt (n-1) (args ++ [bRhs])) f t = error $ "reduceEq: apply: " ++ show t - liftM mconcat $ mapM f vals + {-# SCC "Apply.mappend" #-} liftM mconcat $ mapM f vals reduceEq (PartialApply a b) = do Rhs vals <- lookupEq (VarEntry a) let f (Tag tag nt n args) | n == 0 = return mempty - | otherwise = return $ singleton (Tag tag nt (n-1) (args ++ [singleton (Ident b)])) + | otherwise = do bRhs <- lookupEq (VarEntry b) + return $ singleton (Tag tag nt (n-1) (args ++ [bRhs])) f t = error $ "reduceEq: apply: " ++ show t - liftM mconcat $ mapM f vals + {-# SCC "PartialApply.mappend" #-} liftM mconcat $ mapM f vals reduceEq (Update hp val) = do Rhs hps <- lookupEq (VarEntry hp) valRhs <- lookupEq (VarEntry val) forM_ hps $ \(Heap hp) -> addReduced (HeapEntry hp) valRhs return mempty +-- FIXME: Throw an exception if 'lhs' couldn't be found. lookupEq :: Lhs -> M Rhs lookupEq lhs - = asks $ \eqs -> Map.findWithDefault mempty lhs eqs + = asks $ \(eqs, _sharingMap) -> Map.findWithDefault mempty lhs eqs +-- FIXME: Throw an exception if 'lhs' couldn't be found. +isShared :: Lhs -> M Bool +isShared lhs + = asks $ \(_eqs, sharingMap) -> Map.findWithDefault False lhs sharingMap +setShared :: HeapPointer -> M () +setShared hp = tell (mempty, Endo $ Map.insert (HeapEntry hp) True) diff --git a/src/Grin/HtmlAnnotate.hs b/src/Grin/HtmlAnnotate.hs deleted file mode 100644 --- a/src/Grin/HtmlAnnotate.hs +++ /dev/null @@ -1,111 +0,0 @@ -module Grin.HtmlAnnotate where - -import Text.PrettyPrint -import qualified Text.XHtml -import Text.XHtml hiding (text,blue,white,align) -import qualified Data.Map as Map - -import CompactString -import Grin.Types - -annotate :: Map.Map Renamed Html -> Grin -> String -annotate annotations grin - = h "html" $ h "body" $ h "pre" $ show (ppGrin grin) - where h t s = "<"++t++">"++s++"" - -(<$$>) = ($$) -vsep = vcat -pretty v = text (read (show v)) - -type QualMap = Map.Map CompactString Bool - -grinQualMap :: Grin -> QualMap -grinQualMap grin - = Map.unionsWith (\_ _ -> True) [nodeMap, funcMap, argsMap] - where nodeMap = Map.fromListWith (\_ _ -> True) [ (name, False) | NodeDef{nodeName = Aliased _ name} <- grinNodes grin ] - funcMap = Map.fromListWith (\_ _ -> True) [ (name, False) | FuncDef{funcDefName = Aliased _ name} <- grinFunctions grin ] - argsMap = Map.fromListWith (\_ _ -> True) [ (name, False) | func <- grinFunctions grin, Aliased _ name <- funcDefArgs func ] - -ppGrin :: Grin -> Doc -ppGrin grin - = text "Nodes:" <$$> - vsep (map (ppNodeDef qualMap) (grinNodes grin)) <$$> - (text "CAFs:") <$$> - vsep (map (ppCAF qualMap) (grinCAFs grin)) <$$> - (text "Functions:") <$$> - vsep (map (ppFuncDef qualMap) (grinFunctions grin)) - where qualMap = grinQualMap grin - -ppNodeDef :: QualMap -> NodeDef -> Doc -ppNodeDef qual (NodeDef name nodeType args) - = text "node" <+> ppNodeType setAnchor qual nodeType 0 name <+> hsep (map ppType args) - -ppType PtrType = (text "*") -ppType WordType = (text "#") - -ppNodeType def qual ConstructorNode 0 name = char 'C' <> ppRenamed def qual name -ppNodeType def qual ConstructorNode n name = char 'P' <> int n <> ppRenamed def qual name -ppNodeType def qual FunctionNode 0 name = char 'F' <> ppRenamed def qual name -ppNodeType def qual FunctionNode n name = char 'P' <> int n <> ppRenamed def qual name - -ppRenamed def qual (Aliased n var) -- = pretty var <> if Map.findWithDefault False var qual then char '_' <> int n else empty - = def n (read (show var)) -ppRenamed def qual (Anonymous n) - = def n ('x':show n) -ppRenamed def qual (Builtin p) = char '@' <> pretty p -ppRenamed def qual (External e) = parens (text "foreign" <+> text e) - -ppCAF :: QualMap -> CAF -> Doc -ppCAF qual (CAF name value) - = ppRenamed setAnchor qual name <+> equals <+> ppValue linkToAnchor qual value - -ppFuncDef :: QualMap -> FuncDef -> Doc -ppFuncDef qual (FuncDef name args body) - = hang (hsep (ppRenamed setAnchor qual name : map (ppRenamed setAnchor qual) args) <+> equals) 2 - ((ppBeginExpression qual body)) - -ppBeginExpression :: QualMap -> Expression -> Doc -ppBeginExpression qual e@(_ :>>= _) - = (text "do" <+> ppExpression qual e) -ppBeginExpression qual e = ppExpression qual e - -ppExpression :: QualMap -> Expression -> Doc -ppExpression qual (Unit value) = text "unit" <+> ppValue linkToAnchor qual value -ppExpression qual (Case value alts) - = hang (text "case" <+> ppValue linkToAnchor qual (Variable value) <+> text "of") 2 - (vsep (map (ppAlt qual) alts)) -ppExpression qual (Application fn args) - = hsep (ppRenamed linkToAnchor qual fn:map (ppRenamed linkToAnchor qual) args) -ppExpression qual (Store v) - = text "store" <+> ppValue linkToAnchor qual v -ppExpression qual (a :>> c) - = ppExpression qual a <$$> - ppExpression qual c -ppExpression qual (a :>>= b :-> c) - = (ppValue setAnchor qual (Variable b) <+> text "<-" <+> (ppBeginExpression qual a)) <$$> - ppExpression qual c - -ppAlt qual (value :> exp) = hang (ppValue setAnchor qual value) 2 - (text "->" <+> (ppBeginExpression qual exp)) - -ppValue def qual (Node name nodeType missing args) - = parens (hsep (ppNodeType linkToAnchor qual nodeType missing name : map (ppRenamed def qual) args)) -ppValue def qual (Vector vs) = brackets (hsep (map (ppRenamed def qual) vs)) -ppValue def qual (Hole size) = parens (text "@hole" <+> hsep (replicate size (char '_'))) -ppValue def qual Empty = text "()" -ppValue def qual (Lit lit) = ppLit lit -ppValue def qual (Variable variable) = ppRenamed def qual variable - -ppLit (Lint i) = integer i -ppLit (Lrational r) = text (show r) -ppLit (Lchar char) = text (show char) -ppLit (Lstring string) = text (show string) - - - -linkToAnchor ident var - = zeroWidthText ("") <> text var <> zeroWidthText "" - -setAnchor ident var - = zeroWidthText ("") <> text var <> zeroWidthText "" - diff --git a/src/Grin/Lowering/Apply.hs b/src/Grin/Lowering/Apply.hs --- a/src/Grin/Lowering/Apply.hs +++ b/src/Grin/Lowering/Apply.hs @@ -6,7 +6,6 @@ import CompactString import Grin.Types -import Data.Monoid import Control.Monad.Writer import Control.Monad.State @@ -46,6 +45,8 @@ return $ Case v alts' lowerExpression (Store v) = liftM Store (lowerValue v) +lowerExpression e@Update{} + = return e lowerExpression (Unit v) = liftM Unit (lowerValue v) diff --git a/src/Grin/Lowering/GHCism.hs b/src/Grin/Lowering/GHCism.hs --- a/src/Grin/Lowering/GHCism.hs +++ b/src/Grin/Lowering/GHCism.hs @@ -47,7 +47,9 @@ return $ e' :>> f' lowerExpression (Application (Builtin fn) [a,b]) | Just renamed <- lookup fn renamedOpts = lowerExpression (Application (Builtin renamed) [a,b]) -lowerExpression (Application (Builtin fn) [a,b]) | fn `elem` [">=#",">#","==#","<=#","<#"] +lowerExpression (Application (Builtin fn) [a,b]) | fn `elem` [">=#",">#","==#","/=#","<=#","<#","<##",">##",">=##","<=##","==##" + ,"eqWord#", "neWord#", "leWord#", "geWord#","ltWord#","gtWord#","gtFloat#", "ltFloat#", "geFloat#" + ,"leFloat#", "eqFloat#"] = do tnode <- lookupNode $ fromString "ghc-prim:GHC.Bool.True" fnode <- lookupNode $ fromString "ghc-prim:GHC.Bool.False" v <- newVariable @@ -60,7 +62,7 @@ = do v <- newVariable return $ Store Empty :>>= v :-> Unit (Vector [realWorld, v]) lowerExpression (Application (Builtin "putMVar#") [ptr, val, realWorld]) - = return $ Application (Builtin "update") [ptr, val] :>> Unit (Variable realWorld) + = return $ Application (Builtin "updateMutVar") [ptr, val, realWorld] lowerExpression (Application (Builtin "takeMVar#") [ptr, realWorld]) = do v <- newVariable return $ Application (Builtin "fetch") [ptr] :>>= v :-> Unit (Vector [realWorld, v]) @@ -68,16 +70,16 @@ -- MutVars lowerExpression (Application (Builtin "newMutVar#") [val,realWorld]) - = do v <- newVariable - return $ Store (Variable val) :>>= v :-> Unit (Vector [realWorld, v]) + = return $ Application (Builtin "newMutVar") [val, realWorld] lowerExpression (Application (Builtin "writeMutVar#") [ptr, val, realWorld]) - = return $ Application (Builtin "update") [ptr, val] :>> Unit (Variable realWorld) + = return $ Application (Builtin "updateMutVar") [ptr, val, realWorld] lowerExpression (Application (Builtin "readMutVar#") [ptr, realWorld]) - = do v <- newVariable - return $ Application (Builtin "fetch") [ptr] :>>= v :-> Unit (Vector [realWorld, v]) + = return $ Application (Builtin "readMutVar") [ptr, realWorld] +-- = do v <- newVariable +-- return $ Application (Builtin "fetch") [ptr] :>>= v :-> Unit (Vector [realWorld, v]) -lowerExpression (Application (Builtin "realWorld#") []) - = return $ Unit Empty -- FIXME: Use a special RealWorld value? +--lowerExpression (Application (Builtin "realWorld#") []) +-- = return $ Unit Empty -- FIXME: Use a special RealWorld value? lowerExpression (Application (Builtin "int2Word#") [v]) = return $ Unit (Variable v) lowerExpression (Application (Builtin "word2Int#") [v]) @@ -102,6 +104,13 @@ = do v <- newVariable return $ Application (Builtin "eval") [fn] :>>= v :-> Application (Builtin "apply") [v, realworld] +lowerExpression (Application (External "lhc_prim_castDoubleToWord" tys) [double, realWorld]) + = do v <- newVariable + return $ Application (Builtin "coerceDoubleToWord") [double] :>>= v :-> Unit (Vector [realWorld, v]) +lowerExpression (Application (External "lhc_prim_castWordToDouble" tys) [word, realWorld]) + = do v <- newVariable + return $ Application (Builtin "coerceWordToDouble") [word] :>>= v :-> Unit (Vector [realWorld, v]) + lowerExpression (Application fn vs) = return $ Application fn vs lowerExpression (Case scrut alts) @@ -111,6 +120,8 @@ = return $ Store v lowerExpression (Unit v) = return $ Unit v +lowerExpression (Update size ptr val) + = return $ Update size ptr val lowerLambda :: Lambda -> Lower Lambda lowerLambda (v :-> e) diff --git a/src/Grin/Optimize/Case.hs b/src/Grin/Optimize/Case.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Optimize/Case.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +module Grin.Optimize.Case + ( optimize + ) where + +import Grin.Types +import Traverse +import Grin.Transform + +import Control.Monad.State +import Control.Monad.Reader +import Data.Monoid +import Debug.Trace +import Text.Printf +import Control.Applicative + +import qualified Data.Map as Map + +optimize :: Grin -> Grin +optimize = id -- runTrans (transformExp caseUnion >> transformExp caseSplit) + +{- +do a <- case b of A -> a' + B -> b' + case b of A -> a'' + B -> b'' + c +===> +do a <- case b of A -> new <- a'; a''[a->new]; unit new + B -> new' <- b'; b''[a->new']; unit new' + c +-} +caseUnion :: Expression -> Transform Expression +caseUnion exp + = case exp of + Case scut alts :>>= var :-> Case scut' alts' | scut == scut' + -> do newAlts <- sequence [ unionAlt var alt alts' | alt <- alts ] + caseUnion $ Case scut newAlts + Case scut alts :>>= var :-> Case scut' alts' :>> e | scut == scut' + -> do newAlts <- sequence [ unionAlt var alt alts' | alt <- alts ] + caseUnion $ Case scut newAlts :>>= var :-> e + _other + -> tmapM caseUnion exp + +unionAlt var (cond :> exp) alts + = do new <- newVariableFrom var + otherExp <- renameExp (Map.singleton var new) (findBranch alts) + let newBranch = exp :>>= new :-> otherExp :>> Unit (Variable new) + return $ cond :> newBranch + where findBranch = foldr findBranchCheck unreachable + findBranchCheck (c :> branch) continue + | c == cond = branch -- Found the matching branch, stop looping. + | otherwise = continue -- No match, continue looking. + unreachable = Application (Builtin "unreachable") [] + + +{- +do d <- case a of A -> b + B -> c + e +===> +do case a of A -> new <- b; fn args[d->new] + B -> new' <- c; fn args[d->new'] +-} +caseSplit :: Expression -> Transform Expression +caseSplit exp + = case exp of + Case scut alts :>>= var :-> e + -> do e' <- hoistToTopLevel (Builtin "noname") e + alts' <- forM alts $ \(cond :> branch) -> do new <- newVariableFrom var + e'' <- renameExp (Map.singleton var new) e' + return $ cond :> (branch :>>= new :-> e'') + caseSplit $ Case scut alts' + _other + -> tmapM caseSplit exp + diff --git a/src/Grin/Optimize/Inline.hs b/src/Grin/Optimize/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Optimize/Inline.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE OverloadedStrings #-} +module Grin.Optimize.Inline + ( inlinePass + ) where + +import Grin.Types +import Traverse +import Grin.Transform + +import Control.Monad.State +import Control.Monad.Reader +import Data.Monoid +import Debug.Trace +import Text.Printf +import Control.Applicative + +import qualified Data.Map as Map + +inlinePass :: Grin -> Grin +inlinePass = inlineSimple . inlineCAFs + + +-- Lower cheap CAFs to regular functions. +inlineCAFs :: Grin -> Grin +inlineCAFs grin + = let toInline = map funcDefName $ filter (\def -> funcCategory def `elem` [Cheap]) (grinFunctions grin) + cafsToInline = Map.fromList [ (cafName caf, tag) | caf@CAF{cafValue=Node tag FunctionNode 0 []} <- grinCAFs grin, tag `elem` toInline ] + in runTrans (runReaderT (inlineCAFs') cafsToInline) grin + +type M = ReaderT (Map.Map Renamed Renamed) Transform + +inlineCAFs' :: M () +inlineCAFs' = transformExp inlineCAF + +inlineCAF :: Expression -> M Expression +inlineCAF (Application fn args) + = inlineArgs args (Application fn) +inlineCAF (Unit v) + = inlineValue Unit v +inlineCAF (Store v) + = inlineValue Store v +inlineCAF e = tmapM inlineCAF e + +inlineValue fn (Variable v) + = inlineArgs [v] $ \[v'] -> fn (Variable v') +inlineValue fn (Node tag nt missing args) + = inlineArgs args $ \args' -> fn (Node tag nt missing args') +inlineValue fn (Vector args) + = inlineArgs args $ \args' -> fn (Vector args') +inlineValue fn value + = return $ fn value + +inlineArgs args fn + = do m <- ask + let worker acc [] = return (fn (reverse acc)) + worker acc (x:xs) = case Map.lookup x m of + Nothing -> worker (x:acc) xs + Just caf -> do v <- newVariable + rest <- worker (v:acc) xs + return $ Store (Node caf FunctionNode 0 []) :>>= v :-> rest + worker [] args + + + + + + +--------------------------------- +-- Inline cheap functions. + + +inlineSimple :: Grin -> Grin +inlineSimple grin + = let inp = Map.fromList [ (funcDefName def, (funcCategory def, def)) | def <- grinFunctions grin ] + in runTrans (runReaderT (transformExp inlineSimpleExp) inp) grin + +type Simple = ReaderT (Map.Map Renamed (Category, FuncDef)) Transform + +inlineSimpleExp :: Expression -> Simple Expression +inlineSimpleExp e@(Store (Node tag FunctionNode 0 args)) + = do mbEntry <- findFunc tag + case mbEntry of + Just (Cheap, func) -> lazify =<< doInline func args + Just (Lazy, func) -> lazify =<< doInline func args + _ -> return e +inlineSimpleExp e = tmapM inlineSimpleExp e + +doInline func args + = do let renamedArgs = Map.fromList (zip (funcDefArgs func) (args ++ repeat (Builtin "undefined"))) + lift (renameExp renamedArgs (funcDefBody func)) + +lazify :: Expression -> Simple Expression +lazify (e1 :>>= bind :-> e2) + = do e2' <- lazify e2 + return $ e1 :>>= bind :-> e2' +lazify (e1 :>> e2) + = do e2' <- lazify e2 + return $ e1 :>> e2 +lazify (Application fn args) | not (isBuiltin fn) && not (isExternal fn) + = return $ Store (Node fn FunctionNode 0 args) +lazify (Unit v) + = return $ Store v +lazify (Application (Builtin "eval") [arg]) + = return $ Unit (Variable arg) +lazify e + = do v <- lift newVariable + return $ e :>>= v :-> Store (Variable v) + +findFunc :: Renamed -> Simple (Maybe (Category, FuncDef)) +findFunc name + = asks $ Map.lookup name + + + + + + + +--------------------------------- +-- Other stuff + + +threshold = 10 + +funcSize :: FuncDef -> Int +funcSize def = expressionSize (funcDefBody def) + +expressionSize :: Expression -> Int +expressionSize (e1 :>>= bind :-> e2) + = expressionSize e1 + expressionSize e2 +expressionSize (e1 :>> e2) + = expressionSize e1 + expressionSize e2 +expressionSize (Application fn args) + = 1 +expressionSize (Case scrut alts) + = sum [ expressionSize branch | _ :> branch <- alts ] +expressionSize Store{} + = 1 +expressionSize Unit{} + = 1 + +data Category = NoInline | Lazy | Strict | Cheap deriving (Show,Eq) + +instance Monoid Category where + mempty = Cheap + mappend NoInline _ = NoInline + mappend _ NoInline = NoInline + mappend Strict _ = Strict + mappend _ Strict = Strict + mappend Lazy _ = Lazy + mappend _ Lazy = Lazy + mappend Cheap Cheap = Cheap + +bump :: Category -> Category +bump Cheap = Cheap +bump Lazy = Strict +bump Strict = Strict +bump NoInline = NoInline + +funcCategory :: FuncDef -> Category +--funcCategory FuncDef{funcDefBody = Application (Builtin "eval") _} +-- = InlineLazy +funcCategory def = expressionCategory (funcDefBody def) + +expressionCategory :: Expression -> Category +expressionCategory (e1 :>>= bind :-> e2) + = bump (expressionCategory e1) `mappend` expressionCategory e2 +expressionCategory (e1 :>> e2) + = bump (expressionCategory e1) `mappend` expressionCategory e2 +expressionCategory (Application fn args) | isExternal fn + = NoInline +expressionCategory (Application (Builtin "eval") _args) + = Lazy +expressionCategory (Application (Builtin "apply") _args) + = Lazy +expressionCategory (Application fn args) | isBuiltin fn + = Cheap +expressionCategory (Application fn args) + = Lazy +expressionCategory (Case scrut [_ :> branch]) + = expressionCategory branch +expressionCategory (Case scrut alts) + = NoInline +expressionCategory (Store (Node _tag ConstructorNode _n _args)) + = Cheap +expressionCategory (Store (Node _tag FunctionNode n _args)) | n >= 1 + = Cheap +expressionCategory Store{} + = Lazy +expressionCategory Update{} + = Cheap +expressionCategory Unit{} + = Cheap + + + + diff --git a/src/Grin/Optimize/Simple.hs b/src/Grin/Optimize/Simple.hs --- a/src/Grin/Optimize/Simple.hs +++ b/src/Grin/Optimize/Simple.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} module Grin.Optimize.Simple ( optimize ) where @@ -7,14 +7,16 @@ import Control.Monad.Reader import qualified Data.Map as Map - +import qualified Data.Set as Set +import Data.Maybe +import Traverse -newtype Opt a = Opt {unOpt :: Reader Subst a} - deriving (MonadReader Subst, Monad) +type Opt a = Reader Subst a type Subst = Map.Map Renamed Renamed + optimize :: Grin -> Grin optimize grin = grin{ grinFunctions = map simpleFuncDef (grinFunctions grin)} @@ -22,12 +24,20 @@ simpleFuncDef :: FuncDef -> FuncDef simpleFuncDef def - = def{ funcDefBody = runReader (unOpt (simpleExpression (funcDefBody def))) Map.empty } + = let simplified = runReader (simpleExpression (funcDefBody def)) Map.empty + evaled = runReader (evalOpt simplified) Map.empty + applied = runReader (evalOpt evaled) Map.empty + fetched = runReader (fetchOpt applied) Map.empty + pruned = runReader (casePruneOpt fetched) Map.empty + vectorOpt = runReader (vectorCaseOpt pruned) Map.empty + in def{ funcDefBody = vectorOpt } simpleExpression :: Expression -> Opt Expression simpleExpression (Unit (Variable v1) :>>= v2 :-> t) = do v1' <- doSubst v1 subst v2 v1' (simpleExpression t) +simpleExpression (a :>>= v1 :-> Unit (Variable v2)) | v1 == v2 + = simpleExpression a simpleExpression ((a :>>= b :-> c) :>>= d) = simpleExpression (a :>>= b :-> c :>>= d) simpleExpression ((a :>>= b :-> c) :>> d) @@ -50,8 +60,12 @@ = liftM (Application fn) $ doSubsts values simpleExpression (Store v) = liftM Store $ simpleValue v +simpleExpression (Update size ptr val) + = return (Update size) `ap` doSubst ptr `ap` doSubst val simpleExpression (Unit value) = liftM Unit (simpleValue value) +simpleExpression (Case var []) + = return $ Application (Builtin "unreachable") [] simpleExpression (Case var [Variable v :> alt]) = simpleExpression (Unit (Variable var) :>>= v :-> alt) simpleExpression (Case var alts) | and [ case alt of Unit ret -> ret == cond; _ -> False | cond :> alt <- alts] @@ -90,4 +104,136 @@ subst :: Renamed -> Renamed -> Opt a -> Opt a subst name value = local $ Map.insert name value + + + + +-- do p <- store x +-- y <- fetch p +-- m +-- >>> +-- do y <- unit x +-- m +type FetchOpt a = Reader Heap a +type Heap = Map.Map (Either Renamed Renamed) Expression + +fetchOpt :: Expression -> FetchOpt Expression +fetchOpt e@(Store val :>>= bind :-> _) + = local (Map.insert (Left bind) (Unit val)) + (tmapM fetchOpt e) +fetchOpt e@(Application (Builtin "fetch") [val] :>>= bind :-> _) + = local (Map.insert (Right bind) (Unit (Variable val))) + (tmapM fetchOpt e) +fetchOpt e@(Update size ptr val :>> _) + = local (Map.insert (Left ptr) (Unit (Variable val))) + (tmapM fetchOpt e) +fetchOpt e@(Application (Builtin "fetch") [ptr]) + = do mbVal <- asks $ Map.lookup (Left ptr) + case mbVal of + Nothing -> return e + Just e' -> return e' +fetchOpt e@(Store (Variable val)) + = do mbVal <- asks $ Map.lookup (Right val) + case mbVal of + Nothing -> return e + Just e' -> return e' +fetchOpt e = tmapM fetchOpt e + + +type EvalOpt a = Reader (Map.Map Renamed Value) a + +evalOpt :: Expression -> EvalOpt Expression +evalOpt e@(Store val :>>= bind :-> _) + = local (Map.insert bind val) + (tmapM evalOpt e) +evalOpt e@(Unit val :>>= bind :-> _) + = local (Map.insert bind val) + (tmapM evalOpt e) +evalOpt e@(Update size ptr val :>> _) + = local (Map.insert ptr (Variable val)) + (tmapM evalOpt e) +evalOpt e@(Application (Builtin "eval") [ptr]) + = do node <- isNode (Variable ptr) + if node + then return (Application (Builtin "fetch") [ptr]) + else return e + where isNode (Node _tag FunctionNode n _args) | n >= 1 + = return True + isNode (Node _tag ConstructorNode _n _args) + = return True + isNode (Variable v) + = do mbVal <- asks $ Map.lookup v + case mbVal of + Nothing -> return False + Just val -> isNode val + isNode _ = return False +evalOpt e@(Application (Builtin "apply") [fn,arg]) + = do mbNode <- getNode (Variable fn) + case mbNode of + Just (Node _tag FunctionNode 0 _args) -> error "Grin.Optimize.Simple.applyOpt: Invalid application." + Just (Node tag FunctionNode 1 args) + -> return (Application tag (args ++ [arg])) + Just (Node tag FunctionNode n args) + -> return (Unit (Node tag FunctionNode (n-1) (args ++ [arg]))) + _ -> return e + where getNode node@Node{} + = return (Just node) + getNode (Variable v) + = do mbVal <- asks (Map.lookup fn) + case mbVal of + Nothing -> return Nothing + Just val -> getNode val + getNode _ = return Nothing +evalOpt e = tmapM evalOpt e + + +type ApplyOpt a = Reader (Map.Map Renamed Value) a + +applyOpt :: Expression -> ApplyOpt Expression +applyOpt e@(Unit val :>>= bind :-> _) + = local (Map.insert bind val) + (tmapM applyOpt e) +applyOpt e@(Application (Builtin "apply") [fn,arg]) + = do mbVal <- asks (Map.lookup fn) + case mbVal of + Just (Node _tag FunctionNode 0 _args) -> error "Grin.Optimize.Simple.applyOpt: Invalid application." + Just (Node tag FunctionNode 1 args) + -> return (Application tag (args ++ [arg])) + Just (Node tag FunctionNode n args) + -> return (Unit (Node tag FunctionNode (n-1) (args ++ [arg]))) + _ -> return e +applyOpt e = tmapM applyOpt e + + + +type CasePruneOpt a = Reader Cases a +type Cases = Map.Map Renamed (Set.Set Renamed) + +casePruneOpt :: Expression -> CasePruneOpt Expression +casePruneOpt e@(Unit (Node tag _ _ _) :>>= v :-> _) + = local (Map.insertWith Set.union v (Set.singleton tag)) + (tmapM casePruneOpt e) +casePruneOpt e@(Case scrut alts) + = do mbVals <- asks $ Map.lookup scrut + case mbVals of + Nothing -> tmapM casePruneOpt e + Just vals -> let worker (Node tag _ _ _ :> _) | tag `Set.notMember` vals = Nothing + worker alt = Just alt + in tmapM casePruneOpt (Case scrut (mapMaybe worker alts)) +casePruneOpt e = tmapM casePruneOpt e + + +type VectorCaseOpt a = Reader (Map.Map Renamed [Renamed]) a + +vectorCaseOpt :: Expression -> VectorCaseOpt Expression +vectorCaseOpt e@(Unit (Vector vs) :>>= v :-> _) + = local (Map.insert v vs) + (tmapM vectorCaseOpt e) +vectorCaseOpt e@(Case scrut [ Vector vs :> branch ]) + = do mbVals <- asks $ Map.lookup scrut + case mbVals of + Nothing -> tmapM vectorCaseOpt e + Just vals -> tmapM vectorCaseOpt (foldr (\(v,v') r -> Unit (Variable v) :>>= v' :-> r) branch (zip vals vs)) +vectorCaseOpt e = tmapM vectorCaseOpt e + diff --git a/src/Grin/PreciseDeadCode.hs b/src/Grin/PreciseDeadCode.hs new file mode 100644 --- /dev/null +++ b/src/Grin/PreciseDeadCode.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, BangPatterns #-} +-- FIXME: Use HashSet instead of IntSet. +module Grin.PreciseDeadCode + ( trimDeadCode + ) where + +import Grin.Types + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Writer + +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import Debug.Trace + +trimDeadCode :: Grin -> Grin +trimDeadCode grin + = grin { grinFunctions = map walkFunc [ fn | fn <- grinFunctions grin, isAlive (funcDefName fn) ] + , grinCAFs = [ caf | caf <- grinCAFs grin, isAlive (cafName caf) ] + , grinNodes = [ node | node <- grinNodes grin, isAlive (nodeName node) ] + } + where walkFunc func + = func { funcDefBody = walkExp (funcDefBody func) } + walkExp (e1 :>> e2) + = walkExp e1 :>> walkExp e2 + walkExp (e1 :>>= bind :-> e2) + = if isDead bind + then walkExp e2 + else walkExp e1 :>>= bind :-> walkExp e2 + walkExp fn@(Update size ptr val) + | nodeId ptr `IntSet.member` liveSet + = fn + | otherwise + = Unit Empty + walkExp (Case scrut alts) + = Case scrut (map walkAlt alts) + walkExp fn = fn + walkAlt (alt :> exp) = alt :> walkExp exp + liveSet = liveNodes grin + isDead x = nodeId x `IntSet.notMember` liveSet + isAlive = not . isDead + +liveNodes :: Grin -> IntSet.IntSet +liveNodes grin + = let entryPoint = nodeId (grinEntryPoint grin) + graph = execSM (grinGraph grin) entryPoint IntMap.empty + in reachable entryPoint graph + +reachable :: Int -> DependencyGraph -> IntSet.IntSet +reachable entry graph + = loop (IntSet.singleton entry) (IntSet.singleton entry) + where loop marked new | IntSet.null new = marked + loop marked new + = let reachableByNew = IntSet.unions [ find node | node <- IntSet.toList new ] + unmarkedNew = reachableByNew `IntSet.difference` marked + in loop (marked `IntSet.union` unmarkedNew) unmarkedNew + find key = IntMap.findWithDefault IntSet.empty key graph + + + +newtype SM a = SM { runSM :: Int -> DependencyGraph -> (a, DependencyGraph) } + +instance Monad SM where + return x = SM $ \r s -> (x, s) + f >>= g = SM $ \r s -> case runSM f r s of + (a, !s') -> runSM (g a) r s' + +instance MonadState (IntMap.IntMap IntSet.IntSet) SM where + get = SM $ \_ s -> (s, s) + put s = SM $ \_ _ -> ((), s) + +instance MonadReader Int SM where + ask = SM $ \r s -> (r, s) + local fn m = SM $ \r s -> runSM m (fn r) s + +execSM action r s + = case runSM action r s of + (a, s) -> s + +type DependencyGraph = IntMap.IntMap IntSet.IntSet + +type M a = SM a + +top :: M Int +top = ask + +grinGraph :: Grin -> M () +grinGraph grin + = do mapM_ cafGraph (grinCAFs grin) + mapM_ funcGraph (grinFunctions grin) + +insert k v m = let v' = IntMap.findWithDefault IntSet.empty k m + in IntMap.insertWith IntSet.union k v m + +cafGraph :: CAF -> M () +cafGraph caf + = do deps <- valueGraph (cafValue caf) + modify $ insert (nodeId (cafName caf)) deps + return () + +funcGraph :: FuncDef -> M () +funcGraph func + = do bodyDeps <- local (const (nodeId (funcDefName func))) $ expGraph (funcDefBody func) + modify $ insert (nodeId (funcDefName func)) bodyDeps + return () + +expGraph :: Expression -> M IntSet.IntSet +expGraph (Unit val) + = valueGraph val +expGraph (e1 :>>= bind :-> e2) + = do deps <- expGraph e1 + modify $ insert (nodeId bind) deps + expGraph e2 +expGraph (e1 :>> e2) + = do expGraph e1 + expGraph e2 +expGraph (Application (Builtin "updateMutVar") [ptr, val, realWorld]) + = do return $ IntSet.fromList [nodeId realWorld, nodeId ptr, nodeId val] +expGraph (Update size ptr val) + = do t <- top + let s = IntSet.singleton (nodeId val) + modify $ insert (nodeId ptr) s + return IntSet.empty +expGraph (Application fn args) + = return $ IntSet.fromList (map nodeId (fn:args)) +expGraph (Case scrut alts) + = do t <- top + modify $ insert t (IntSet.singleton (nodeId scrut)) + depss <- mapM altGraph alts + forM_ depss $ \deps -> + do modify $ insert (nodeId scrut) deps + forM_ (IntSet.toList deps) $ \dep -> + modify $ insert dep (IntSet.singleton (nodeId scrut)) + return $ IntSet.singleton (nodeId scrut) +expGraph (Store val) + = valueGraph val + +nodeId :: Renamed -> Int +nodeId (Aliased uid _name) = uid +nodeId (Anonymous uid) = uid +nodeId (Builtin{}) = -1 +nodeId (External{}) = -1 + +altGraph :: Alt -> M IntSet.IntSet +altGraph (value :> exp) + = liftM2 (IntSet.union) (valueGraph value) (expGraph exp) + +valueGraph :: Value -> M IntSet.IntSet +valueGraph (Node tag _nt _partial args) = return $ IntSet.fromList (nodeId tag : map nodeId args) +valueGraph (Vector vs) = return $ IntSet.fromList (map nodeId vs) +valueGraph Lit{} = return IntSet.empty +valueGraph Hole{} = return IntSet.empty +valueGraph Empty = return IntSet.empty +valueGraph (Variable v) = return $ IntSet.singleton (nodeId v) + diff --git a/src/Grin/Pretty.hs b/src/Grin/Pretty.hs --- a/src/Grin/Pretty.hs +++ b/src/Grin/Pretty.hs @@ -20,6 +20,9 @@ funcMap = Map.fromListWith (\_ _ -> True) [ (name, False) | FuncDef{funcDefName = Aliased _ name} <- grinFunctions grin ] argsMap = Map.fromListWith (\_ _ -> True) [ (name, False) | func <- grinFunctions grin, Aliased _ name <- funcDefArgs func ] +instance Pretty Grin where + pretty = ppGrin + ppGrin :: Grin -> Doc ppGrin grin = dullblue (text "Nodes:") <$$> @@ -36,6 +39,7 @@ ppType PtrType = blue (text "*") ppType WordType = white (text "#") +ppType NodeType = white (text "!") ppNodeType qual nt n name = green (worker qual nt n name) @@ -47,7 +51,7 @@ ppRenamed qual (Aliased n var) = pretty var <> if True || Map.findWithDefault False var qual then char '_' <> pretty n else empty ppRenamed qual (Anonymous n) = char 'x' <> pretty n ppRenamed qual (Builtin p) = char '@' <> pretty p -ppRenamed qual (External e) = parens (text "foreign" <+> text e) +ppRenamed qual (External e tys)= parens (text "foreign" <+> text e) -- FIXME: Show types. ppCAF :: QualMap -> CAF -> Doc ppCAF qual (CAF name value) @@ -70,6 +74,8 @@ indent 2 (vsep (map (ppAlt qual) alts)) ppExpression qual (Application fn args) = hsep (ppRenamed qual fn:map (ppRenamed qual) args) +ppExpression qual (Update size ptr val) + = blue (text "update") <+> int size <+> ppRenamed qual ptr <+> ppRenamed qual val ppExpression qual (Store v) = blue (text "store") <+> ppValue qual v ppExpression qual (a :>> c) diff --git a/src/Grin/SimpleCore.hs b/src/Grin/SimpleCore.hs --- a/src/Grin/SimpleCore.hs +++ b/src/Grin/SimpleCore.hs @@ -11,6 +11,8 @@ , ModuleIdent , moduleIdent , SimpleType(..) + , SimpleEnum(..) + , Ty(..) , SimpleDef(..) , SimpleExp(..) , simpleDefArity @@ -21,7 +23,7 @@ import Grin.Types (Variable) import Grin.SimpleCore.Types -import Language.Core (Ty,Tdef,Vdef(..)) +import Language.Core (Tdef,Vdef(..)) -- TODO: The Language.Core library uses parsec and is fairly slow. We could write -- TODO: a faster version using Happy. import qualified Language.Core as Core @@ -33,6 +35,7 @@ import qualified Data.ByteString.Lazy.Char8 as L import Control.Monad.RWS import Data.List +import Data.Maybe import Traverse @@ -56,10 +59,12 @@ in SimpleModule { modulePackage = L.unpack pkgname , moduleName = L.unpack modname , moduleTypes = concatMap tdefToSimpleTypes tdefs + , moduleEnums = mapMaybe tdefToSimpleEnum tdefs , moduleDefs = simpleDefs } where allDefs = concatMap (\x -> case x of Core.Nonrec d -> [d]; Core.Rec ds -> ds) vdefs emptyScope = Scope { currentScope = Map.empty - , currentModule = (pkgname, modname) } + , currentModule = (pkgname, modname) + , currentContext= Lazy } tdefToSimpleTypes :: Core.Tdef -> [SimpleType] tdefToSimpleTypes (Core.Data _ _ cdefs) = map cdefToSimpleType cdefs @@ -68,7 +73,18 @@ cdefToSimpleType :: Core.Cdef -> SimpleType cdefToSimpleType (Core.Constr qual _ tys) = SimpleType { simpleTypeName = qualToCompact qual , simpleTypeArity = length tys } +cdefToSimpleType (Core.GadtConstr{}) = error "GADTs aren't yet supported!" +tdefToSimpleEnum :: Core.Tdef -> Maybe SimpleEnum +tdefToSimpleEnum (Core.Data qual [] cdefs) + = Just (SimpleEnum { simpleEnumName = qualToCompact qual + , simpleEnumMembers = mapMaybe cdefToSimpleEnum cdefs }) +tdefToSimpleEnum _ = Nothing + +cdefToSimpleEnum :: Core.Cdef -> Maybe CompactString +cdefToSimpleEnum (Core.Constr qual [] []) = Just (qualToCompact qual) +cdefToSimpleEnum _ = Nothing + sdefDeps :: Core.Exp -> [(String, String)] sdefDeps exp = let free = Set.toList $ freeVariables exp @@ -81,14 +97,24 @@ isPrimitiveQual (pkg,mod,_ident) = pkg == L.pack "ghczmprim" && mod == L.pack "GHCziPrim" - +isEnumPrimitive (_pkg, _mod, ident) + = ident == L.pack "tagToEnumzh" || ident == L.pack "dataToTagzh" --type ScopeEnv = Map.Map (Core.Qual Core.Id) Renamed -data Scope = Scope { currentScope :: Map.Map (Core.Qual Core.Id) Ty - , currentModule :: (Core.Pkgname, Core.Mname) } +data Scope = Scope { currentScope :: Map.Map (Core.Qual Core.Id) Core.Ty + , currentModule :: (Core.Pkgname, Core.Mname) + , currentContext :: Context } +data Context = Strict | Lazy deriving Eq type M = RWS Scope [SimpleDef] Int +setContext :: Context -> M a -> M a +setContext cxt + = local (\scope -> scope{ currentContext = cxt }) + +askContext :: M Context +askContext = asks currentContext + vdefToSimpleDef :: Core.Vdef -> M () vdefToSimpleDef vdef = let (args, body) = splitExp (vdefExp vdef) @@ -102,16 +128,24 @@ , simpleDefBody = body' , simpleDefDeps = sdefDeps body }] - expToSimpleExp :: Core.Exp -> M SimpleExp -expToSimpleExp (Core.Var (pkg,mod,ident)) | pkg == L.pack "ghczmprim" && mod == L.pack "GHCziPrim" +expToSimpleExp (Core.App (Core.Appt (Core.Var qual@(_pkg,_mod,ident)) t) (Core.Var var)) + | isPrimitiveQual qual && isEnumPrimitive qual + = return $ EnumPrimitive (qualToCompact (L.empty, L.empty, ident)) (qualToCompact var) (tyToSimpleTy t) +expToSimpleExp (Core.Var qual@(pkg,mod,ident)) | isPrimitiveQual qual = return $ Primitive (qualToCompact (L.empty, L.empty, ident)) expToSimpleExp (Core.Var var) = do isUnboxed <- varIsStrictPrimitive var return $ Var (qualToCompact var) isUnboxed expToSimpleExp (Core.Dcon con) = return $ Dcon (qualToCompact con) expToSimpleExp (Core.Lit lit) = return $ Lit $ fromCoreLit lit -expToSimpleExp e@Core.App{} = let (f,args) = collectApps e - in return App `ap` expToSimpleExp f `ap` mapM expToSimpleExp args +expToSimpleExp e@Core.App{} = do let (f,args) = collectApps e + e' <- expToSimpleExp f + cxt <- askContext + case e' of + Primitive{} -> return (App e') `ap` mapM expToSimpleExp args + External{} -> return (App e') `ap` mapM expToSimpleExp args + _ | cxt == Strict -> return (App e') `ap` mapM expToSimpleExp args + | otherwise -> return (App e') `ap` mapM lambdaLiftExp args expToSimpleExp (Core.Appt a _) = expToSimpleExp a expToSimpleExp (Core.Lamt _ e) = expToSimpleExp e -- We remove lambdas by translating them to let expressions. @@ -133,10 +167,10 @@ = bindDefs defs $ return LetRec `ap` mapM lambdaLift defs `ap` expToSimpleExp e expToSimpleExp (Core.Case e bind ty [Core.Adefault cond]) | typeIsStrictPrimitive (snd bind) = bindVariable bind $ - return (LetStrict (qualToCompact (fst bind))) `ap` expToSimpleExp e `ap` expToSimpleExp cond + return (LetStrict (qualToCompact (fst bind))) `ap` setContext Strict (expToSimpleExp e) `ap` expToSimpleExp cond expToSimpleExp (Core.Case e bind ty alts) = bindVariable bind $ - do e' <- expToSimpleExp e + do e' <- setContext Strict $ expToSimpleExp e alts' <- mapM altToSimpleAlt alts let constr = if typeIsStrictPrimitive (snd bind) then CaseStrict else Case return $ constr e' (qualToCompact $ fst bind) alts' @@ -146,6 +180,10 @@ expToSimpleExp (Core.Label label) = return $ Label label expToSimpleExp (Core.Note note e) = {- return (Note note) `ap` -} expToSimpleExp e +tyToSimpleTy :: Core.Ty -> Ty +tyToSimpleTy (Core.Tcon con) = Tcon (qualToCompact con) +tyToSimpleTy ty = error $ "Invalid enum type: " ++ show ty + tyToFFITypes :: Core.Ty -> [FFIType] tyToFFITypes (Core.Tarrow (Core.Tcon con) rest) = conToFFIType con : tyToFFITypes rest @@ -154,26 +192,26 @@ = case ret of Core.Tapp (Core.Tcon tuple) (Core.Tapp (Core.Tcon state) (Core.Tcon realworld)) | tuple == z1h && state == statezh && realworld == theRealWorld - -> [Unit] + -> [UnitType] Core.Tapp (Core.Tapp (Core.Tcon tuple) (Core.Tapp (Core.Tcon state) (Core.Tcon realworld))) (Core.Tcon con) | tuple == z2h && state == statezh && realworld == theRealWorld -> [conToFFIType con] - _ -> [Invalid] + _ -> [InvalidType] where z1h = mkPrimQual "Z1H" z2h = mkPrimQual "Z2H" statezh = mkPrimQual "Statezh" theRealWorld = mkPrimQual "RealWorld" -tyToFFITypes ty = [Invalid] -- error $ "Unrecognized ffi type: " ++ show ty +tyToFFITypes ty = [InvalidType] -- error $ "Unrecognized ffi type: " ++ show ty mkPrimQual name = (L.pack "ghczmprim", L.pack "GHCziPrim", L.pack name) conToFFIType :: Core.Qual Core.Tcon -> FFIType conToFFIType con - | con == wordzh = Word - | con == intzh = Int - | con == addrzh = Addr - | otherwise = Invalid + | con == wordzh = UnsignedType + | con == intzh = SignedType + | con == addrzh = PointerType + | otherwise = InvalidType where wordzh = mkPrimQual "Wordzh" intzh = mkPrimQual "Intzh" addrzh = mkPrimQual "Addrzh" @@ -263,10 +301,34 @@ , map qualToCompact lambdaScope , length realArgs ) +lambdaLiftExp :: Core.Exp -> M SimpleExp +lambdaLiftExp e@Core.Var{} = expToSimpleExp e +lambdaLiftExp e@Core.Lit{} = expToSimpleExp e +lambdaLiftExp e@Core.Dcon{} = expToSimpleExp e +lambdaLiftExp (Core.Appt e _t) = lambdaLiftExp e +lambdaLiftExp e@Core.App{} | (Core.Var qual, _args) <- collectApps e + , isPrimitiveQual qual + = expToSimpleExp e +lambdaLiftExp exp + = do (pkg, mod) <- asks currentModule + scope <- asks currentScope + unique <- newUnique + let allFreeVars = freeVariables exp `Set.intersection` Map.keysSet scope + lambdaScope = Set.toList allFreeVars + lambdaScopeTyped <- mapM (\var -> do t <- varType var; return (var, t)) lambdaScope + let + realArgs = map qualToCompact lambdaScope + toplevelName = (pkg,mod,L.pack "@lifted_exp@_" `L.append` L.pack (show unique)) -noType :: Core.Ty -noType = error "Urk, types shouldn't be needed" + bindVariables (lambdaScopeTyped) $ + vdefToSimpleDef' (qualToCompact toplevelName) realArgs exp + return $ App (Var (qualToCompact toplevelName) False) [ Var (qualToCompact arg) False | arg <- lambdaScope ] + {-return ( qualToCompact toplevelName + , map qualToCompact lambdaScope + , length realArgs )-} + + freeVariables :: Core.Exp -> Set.Set (Core.Qual Core.Id) freeVariables (Core.Var qual) = Set.singleton qual freeVariables (Core.Dcon qual) = Set.singleton qual @@ -289,11 +351,11 @@ -bindVariable :: (Core.Qual Core.Id, Ty) -> M a -> M a +bindVariable :: (Core.Qual Core.Id, Core.Ty) -> M a -> M a bindVariable (var, ty) = local $ \scope -> scope{ currentScope = Map.insert var ty (currentScope scope)} -bindVariables :: [(Core.Qual Core.Id, Ty)] -> M a -> M a +bindVariables :: [(Core.Qual Core.Id, Core.Ty)] -> M a -> M a bindVariables [] = id bindVariables (x:xs) = bindVariable x . bindVariables xs @@ -311,7 +373,7 @@ Nothing -> False Just ty -> typeIsStrictPrimitive ty -varType :: Core.Qual Core.Id -> M Ty +varType :: Core.Qual Core.Id -> M Core.Ty varType var = asks $ \st -> Map.findWithDefault errMsg var (currentScope st) where errMsg = error $ "Couldn't find type for: " ++ show var @@ -327,7 +389,7 @@ return (pkg, mod, ident `L.append` L.pack (show u)) -splitExp :: Core.Exp -> ([(Core.Qual Core.Id,Ty)], Core.Exp) +splitExp :: Core.Exp -> ([(Core.Qual Core.Id,Core.Ty)], Core.Exp) splitExp (Core.Lam b exp) = let (args,body) = splitExp exp in (b:args, body) splitExp (Core.Lamt _ exp) = splitExp exp diff --git a/src/Grin/SimpleCore/DeadCode.hs b/src/Grin/SimpleCore/DeadCode.hs --- a/src/Grin/SimpleCore/DeadCode.hs +++ b/src/Grin/SimpleCore/DeadCode.hs @@ -10,7 +10,7 @@ -removeDeadCode :: [(String,String)] -> [String] -> Map.Map (String,String) SimpleModule -> ([SimpleType], [SimpleDef]) +removeDeadCode :: [(String,String)] -> [String] -> Map.Map (String,String) SimpleModule -> ([SimpleType], [SimpleEnum], [SimpleDef]) removeDeadCode initialModules entryPoints modules = let entryPointsCompact = map fromString entryPoints addModules mods entries = entries `Map.union` Map.unions (map (entityMap `find`) mods) @@ -26,12 +26,13 @@ neededMods = map (modules `find`) modDeps tdefs = concatMap moduleTypes neededMods defs = concatMap moduleDefs neededMods - in ( [ tdef | tdef <- tdefs, simpleTypeName tdef `Set.member` deps ] + in ( [ tdef | tdef <- tdefs] -- Unused nodes are removed later. + , concatMap moduleEnums neededMods , [ def | def <- defs, simpleDefName def `Set.member` deps ] ) where find m k = case Map.lookup k m of Just v -> v - Nothing -> error $ "Couldn't find key: " ++ show k + Nothing -> error $ "Grin.SimpleCore.DeadCode.removeDeadCode: Couldn't find key: " ++ show k entityMap :: Map.Map (String,String) (Map.Map CompactString ([(String,String)], Set.Set CompactString)) entityMap = flip Map.map modules $ \smod -> Map.fromList $ [ (simpleDefName def, (simpleDefDeps def, defDependencies def)) | def <- moduleDefs smod ] ++ @@ -45,6 +46,7 @@ dependencies :: SimpleExp -> Set.Set CompactString dependencies (Var var isUnboxed) = Set.singleton var dependencies Primitive{}= Set.empty +dependencies (EnumPrimitive prim arg ty) = Set.singleton arg dependencies (Dcon var) = Set.singleton var dependencies Lit{} = Set.empty dependencies (App a args) = Set.unions (dependencies a : map dependencies args) diff --git a/src/Grin/SimpleCore/Types.hs b/src/Grin/SimpleCore/Types.hs --- a/src/Grin/SimpleCore/Types.hs +++ b/src/Grin/SimpleCore/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wwarn #-} module Grin.SimpleCore.Types where import CompactString @@ -13,6 +14,7 @@ = SimpleModule { modulePackage :: String , moduleName :: String , moduleTypes :: [SimpleType] + , moduleEnums :: [SimpleEnum] , moduleDefs :: [SimpleDef] } @@ -24,6 +26,11 @@ , simpleTypeArity :: Int } +data SimpleEnum + = SimpleEnum { simpleEnumName :: CompactString + , simpleEnumMembers :: [CompactString] + } + data SimpleDef = SimpleDef { simpleDefName :: CompactString , simpleDefArgs :: [CompactString] @@ -36,6 +43,7 @@ data SimpleExp = Var CompactString Bool | Primitive CompactString + | EnumPrimitive CompactString CompactString Ty | Dcon CompactString | Lit Lit | App SimpleExp [SimpleExp] @@ -49,8 +57,11 @@ | Label String | Note String SimpleExp -data FFIType = Word | Int | Addr | Unit | Invalid +data Ty = Tcon CompactString +data FFIType = UnsignedType | SignedType | PointerType | UnitType | InvalidType + deriving ( Show, Eq, Ord ) + data Alt = Acon CompactString [CompactString] SimpleExp | Alit Lit SimpleExp @@ -65,10 +76,12 @@ $(derive makeBinary ''Alt) $(derive makeBinary ''Lit) +$(derive makeBinary ''Ty) $(derive makeBinary ''FFIType) $(derive makeBinary ''SimpleExp) $(derive makeBinary ''SimpleDef) $(derive makeBinary ''SimpleType) +$(derive makeBinary ''SimpleEnum) $(derive makeBinary ''SimpleModule) diff --git a/src/Grin/Stage2/Backend/C.hs b/src/Grin/Stage2/Backend/C.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Backend/C.hs @@ -0,0 +1,829 @@ +{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-} +module Grin.Stage2.Backend.C + ( compile + , compileFastCode + , grinToC + ) where + +import CompactString +import Grin.Stage2.Types +import qualified Grin.Stage2.Pretty as Grin (ppExpression) + +import Text.PrettyPrint.ANSI.Leijen hiding (()) + +import System.Process +import System.FilePath +import System.Directory +import Data.Char +import Text.Printf +import System.IO +import System.Exit +import Foreign.Storable +import qualified Data.Map as M + +import Paths_lhc + +compile :: Grin -> FilePath -> IO () +compile = compile' ["--debug", "-ggdb"] + +compileFastCode :: Grin -> FilePath -> IO () +compileFastCode = compile' ["-O2"] + +compile' :: [String] -> Grin -> FilePath -> IO () +compile' gccArgs grin target + = do rts <- getDataFileName ("rts" "rts.c") + let cTarget = replaceExtension target "c" + copyFile rts cTarget + appendFile cTarget (show cCode) + dDir <- getDataDir + let ltmDir = dDir "rts/ltm/" + ltmFiles <- getDirectoryContents ltmDir + let ltmOptions = ["-I"++ltmDir, "-DXMALLOC=GC_malloc", "-DXFREE=GC_free", "-DXREALLOC=GC_realloc"] ++ map (ltmDir ) [ file | file <- ltmFiles, takeExtension file == ".c" ] + pid <- runCommand (unwords $ cmdLine ++ ltmOptions) + ret <- waitForProcess pid + case ret of + ExitSuccess -> return () + _ -> do hPutStrLn stderr "C code failed to compile." + exitWith ret + where cCode = grinToC grin + cFile = replaceExtension target "c" + cmdLine = ["gcc", "-w", "-lm", "-I/usr/include/gc/", "-lgc", cFile, "-o", target] ++ gccArgs + + + +------------------------------------------------------ +-- Grin -> C + +grinToC :: Grin -> Doc +grinToC grin + = vsep [ comment "CAFs:" + , vsep (map ppCAF (grinCAFs grin)) + , comment "Return arguments:" + , vsep (map ppCAF returnArguments) + , comment "Function prototypes:" + , vsep (map ppFuncDefProtoType (grinFunctions grin)) + , comment "Functions:" + , vsep (map ppFuncDef (grinFunctions grin)) + , comment "Main:" + , ppMain (grinCAFs grin) (grinEntryPoint grin) + , linebreak + ] + +returnArguments :: [CAF] +returnArguments = [ CAF{ cafName = Aliased n "lhc_return", cafValue = Lit (Lint 0)} | n <- [1..20] ] + +unitSize = sizeOf (undefined :: Int) + +ppMain :: [CAF] -> Renamed -> Doc +ppMain cafs entryPoint + = text "int" <+> text "main" <> parens (text "int argc" <> comma <+> text "char *argv[]") <+> char '{' <$$> + indent 2 ( text "global_argc = argc;" <$$> + text "global_argv = argv;" <$$> + text "GC_init();" <$$> + --text "GC_set_max_heap_size(1024*1024*1024);" <$$> + vsep [ vsep [ ppRenamed name <+> equals <+> alloc (int (4 * unitSize)) <> semi + , ppRenamed name <> brackets (int 0) <+> equals <+> int (uniqueId tag) <> semi] + | CAF{cafName = name, cafValue = Node tag _nt _missing} <- cafs ] <$$> + ppRenamed entryPoint <> parens empty <> semi <$$> {- ppFooter <$$> -} text "return 0" <> semi) <$$> + char '}' + +ppFooter :: Doc +ppFooter = vsep [ text "printf(\"Collections: %d\\n\", GC_gc_no);" + , text "printf(\"Total allocations: %lu\\n\", GC_get_total_bytes());" + , text "printf(\"Heap size: %ld\\n\", GC_get_heap_size());" + ] + +ppBumpAlloc :: Doc +ppBumpAlloc + = text "void*" <+> text "alloc" <> parens (text "int" <+> text "size") <+> char '{' <$$> + indent 2 (vsep [ text "static void *p = NULL, *limit = NULL;" + , text "void* t;" + , text "int max;" + , text "if (p == NULL) { " + , text " p = GC_MALLOC(" <> int blockSize <> text " + 10*8);" + , text " limit = p + " <> int blockSize <> text ";" + , text "}" + , text "if (p+size > limit) {" + , text " max = " <> int blockSize <> text " > size ? " <> int blockSize <> text " : size;" + , text " p = GC_MALLOC(max + 10*8);" + , text " limit = p + max;" + , text "}" + , text "t = p;" + , text "p += size;" + , text "return t;" + ]) <$$> + char '}' + where blockSize = 1024*4 + +ppCAF :: CAF -> Doc +ppCAF CAF{cafName = name, cafValue = Node tag _nt _missing} + = unitp <+> ppRenamed name <> semi +ppCAF CAF{cafName = name, cafValue = Lit (Lstring str)} + = comment str <$$> + unitp <+> ppRenamed name <+> equals <+> cunitp <+> escString (str++"\0") <> semi +ppCAF CAF{cafName = name, cafValue = Lit (Lint i)} + = unitp <+> ppRenamed name <+> equals <+> cunitp <+> int (fromIntegral i) <> semi +ppCAF caf = error $ "Grin.Stage2.Backend.ppCAF: Invalid CAF: " ++ show (cafName caf) + +ppFuncDefProtoType :: FuncDef -> Doc +ppFuncDefProtoType func + = void <+> ppRenamed (funcDefName func) <> argList <> semi + where argList = parens (hsep $ punctuate comma $ [ unitp <+> ppRenamed arg | arg <- funcDefArgs func ]) + +ppFuncDef :: FuncDef -> Doc +ppFuncDef func + = void <+> ppRenamed (funcDefName func) <> argList <+> char '{' <$$> + indent 2 (body <$$> text "return" <> semi) <$$> + char '}' + where argList = parens (hsep $ punctuate comma $ [ unitp <+> ppRenamed arg | arg <- funcDefArgs func ]) + body = ppExpression (map cafName (take (funcDefReturns func) returnArguments)) (funcDefBody func) + +mkBind binds vals + = vsep [ bind =: val | (bind, val) <- zip binds (vals ++ repeat (int 0)) ] + +ppExpression :: [Renamed] -> Expression -> Doc +ppExpression binds exp + = case exp of + Constant value -> out [valueToDoc value] + Application fn args -> + case fn of + Builtin prim -> ppBuiltin binds prim args + External ext tys-> ppExternal binds ext tys args + _other -> ppFunctionCall binds fn args + Fetch nth variable -> out [ ppRenamed variable <> brackets (int nth) ] -- out = var[nth]; + Unit variables -> out (map ppRenamed variables) + StoreHole size -> out [ alloc (int $ max 4 size * unitSize) ] + Store variables -> out [ alloc (int $ max 4 (length variables) * unitSize) ] <$$> + vsep [ writeArray (head binds) n var | (n,var) <- zip [0..] variables ] + Case scrut alts -> ppCase binds scrut alts + a :>>= binds' :-> b -> vsep [ declareVars binds' + , ppExpression binds' a + , ppExpression binds b ] + where out = mkBind binds + +ppBuiltin binds prim args + = case M.lookup prim builtins of + Nothing -> panic $ "unknown builtin: " ++ show prim + Just fn -> fn args + where builtins = M.fromList + [ "coerceDoubleToWord" ~> \[arg] -> out [ ppRenamed arg ] + , "noDuplicate#" ~> \[arg] -> out [ ppRenamed arg ] + , "chr#" ~> \[arg] -> out [ ppRenamed arg ] + , "ord#" ~> \[arg] -> out [ ppRenamed arg ] + , "byteArrayContents#" ~> \[arg] -> out [ ppRenamed arg ] + , "realWorld#" ~> \_ -> out [ int 0 ] + , "unreachable" ~> \_ -> panic "unreachable" + + -- Word arithmetics + , "timesWord#" ~> binOp cunit "*" + , "plusWord#" ~> binOp cunit "+" + , "minusWord#" ~> binOp cunit "-" + , "quotWord#" ~> binOp cunit "/" + , "remWord#" ~> binOp cunit "%" + + -- Int arithmetics + , "*#" ~> binOp csunit "*" + , "+#" ~> binOp csunit "+" + , "-#" ~> binOp csunit "-" + , "quotInt#" ~> binOp csunit "/" + , "remInt#" ~> binOp csunit "%" + , "negateInt#" ~> unOp csunit "-" + + -- Comparing + , "==#" ~> cmpOp csunit "==" + , "/=#" ~> cmpOp csunit "!=" + , ">#" ~> cmpOp csunit ">" + , ">=#" ~> cmpOp csunit ">=" + , "<#" ~> cmpOp csunit "<" + , "<=#" ~> cmpOp csunit "<=" + + , "eqWord#" ~> cmpOp cunit "==" + , "neWord#" ~> cmpOp cunit "!=" + , "gtWord#" ~> cmpOp cunit ">" + , "geWord#" ~> cmpOp cunit ">=" + , "ltWord#" ~> cmpOp cunit "<" + , "leWord#" ~> cmpOp cunit "<=" + + -- Bit operations + , "and#" ~> binOp cunit "&" + , "or#" ~> binOp cunit "|" + , "xor#" ~> binOp cunit "^" + , "not#" ~> unOp cunit "~" + , "uncheckedShiftL#" ~> binOp' cunit cs32 "<<" + , "uncheckedShiftR#" ~> binOp' cunit cs32 ">>" + , "uncheckedIShiftL#" ~> binOp' csunit cs32 "<<" + , "uncheckedIShiftR#" ~> binOp' csunit cs32 ">>" + , "uncheckedIShiftRA#" ~> binOp' csunit cs32 ">>" -- FIXME + , "uncheckedIShiftRL#" ~> binOp' csunit cs32 ">>" -- FIXME + + -- Narrowing + , "narrow8Word#" ~> unOp cu8 "" + , "narrow16Word#" ~> unOp cu16 "" + , "narrow32Word#" ~> unOp cu32 "" + , "narrow8Int#" ~> unOp cs8 "" + , "narrow16Int#" ~> unOp cs16 "" + , "narrow32Int#" ~> unOp cs32 "" + + -- Mics IO + , "newPinnedByteArray#" ~> \[size, realWorld] -> out [ ppRenamed realWorld + , alloc (cunit <+> ppRenamed size) ] + , "newByteArray#" ~> \[size, realWorld] -> out [ ppRenamed realWorld + , alloc (cunit <+> ppRenamed size) ] + -- FIXME: Array not aligned. + , "newAlignedPinnedByteArray#" ~> \[size, alignment, realWorld] + -> out [ ppRenamed realWorld + , alloc (cunit <+> ppRenamed size) ] + , "unsafeFreezeByteArray#" ~> \[arr, realWorld] -> out [ ppRenamed realWorld, ppRenamed arr ] + , "unsafeFreezeArray#" ~> \[arr, realWorld] -> out [ ppRenamed realWorld, ppRenamed arr ] + , "updateMutVar" ~> \[ptr, val, realWorld] -> vsep [ writeArray ptr 0 val + , out [ ppRenamed realWorld ] ] + , "newMutVar" ~> \[val, realWorld] -> vsep [ out [ ppRenamed realWorld, alloc (int $ 4 * unitSize) ] + , writeArray (binds!!1) 0 val ] + , "readMutVar" ~> \[val, realWorld] -> out [ ppRenamed realWorld + , ppRenamed val <> brackets (int 0) ] + + , "mkWeak#" ~> \[key, val, finalizer, realWorld] + -> out [ ppRenamed realWorld, int 0 ] + , "update" ~> \(ptr:values) -> vsep [ writeArray ptr n value | (n,value) <- zip [0..] values ] + , "touch#" ~> \[ptr, realWorld] -> out [ ppRenamed realWorld ] + , "newArray#" ~> \[size, elt, realWorld] -> out [ ppRenamed realWorld + , text "rts_newArray" <> parens (sep $ punctuate comma [alloc (cunit <> ppRenamed size <+> text "*" <+> int unitSize) + ,cunit <+> ppRenamed elt + ,cunit <> ppRenamed size]) + ] + , "writeArray#" ~> \[arr, idx, elt, realWorld] -> vsep [ writeAnyArray unit arr idx elt + , out [ ppRenamed realWorld ] ] + , "readArray#" ~> \[arr, idx, realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cunitp arr idx ] + , "indexArray#" ~> \[arr, idx] -> out [ indexAnyArray cunitp arr idx ] + + -- Arrays + , "writeCharArray#" ~> \[arr,idx,chr,realWorld] -> vsep [ writeAnyArray u8 arr idx chr + , out [ ppRenamed realWorld ] ] + , "writeWord8Array#" ~> \[arr,idx,chr,realWorld] -> vsep [ writeAnyArray u8 arr idx chr + , out [ ppRenamed realWorld ] ] + , "indexCharOffAddr#" ~> \[arr,idx] -> out [ indexAnyArray cu8p arr idx ] + , "readCharArray#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cu8p arr idx ] + , "readInt32OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cs32p arr idx ] + , "readInt8OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cs8p arr idx ] + , "readAddrOffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cunitp arr idx ] + , "readWord64OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cu64p arr idx ] + , "readWord8OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cu8p arr idx ] + , "readWideCharOffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld + , indexAnyArray cs32p arr idx ] + , "writeInt8OffAddr#" ~> \[arr,idx,word,realWorld] -> vsep [ writeAnyArray s8 arr idx word + , out [ ppRenamed realWorld] ] + , "writeWord64OffAddr#" ~> \[arr,idx,word,realWorld] -> vsep [ writeAnyArray u64 arr idx word + , out [ ppRenamed realWorld] ] + , "writeAddrOffAddr#" ~> \[arr,idx,ptr,realWorld] -> vsep [ writeAnyArray unit arr idx ptr + , out [ ppRenamed realWorld] ] + , "writeWideCharOffAddr#" ~> \[arr,idx,char,realWorld] -> vsep [ writeAnyArray s32 arr idx char + , out [ ppRenamed realWorld] ] + ] + (~>) = (,) + out = mkBind binds + binOp ty fn [a,b] = out [ parens (ty <+> ppRenamed a <+> text fn <+> ty <+> ppRenamed b) ] + binOp' ty ty' fn [a,b] = out [ parens (ty <+> ppRenamed a <+> text fn <+> ty' <+> ppRenamed b) ] + unOp ty fn [a] = out [ parens (text fn <+> parens (ty <+> ppRenamed a)) ] + cmpOp ty fn [a,b] = ifStatement (ty <> ppRenamed a <+> text fn <+> ty <> ppRenamed b) + (out [ int 1 ]) + (out [ int 0 ]) + writeAnyArray ty arr idx elt + = parens (parens (ty <> char '*') <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) + <+> equals <+> + parens ty <+> cunit <+> ppRenamed elt <> semi + indexAnyArray ty arr idx + = parens (ty <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) + + +ppExternal binds "isDoubleNaN" tys [double, realWorld] + = mkBind binds [ ppRenamed realWorld + , text "isnan" <> parens (castToDouble double) ] +ppExternal binds "isDoubleInfinite" tys [double, realWorld] + = mkBind binds [ ppRenamed realWorld + , text "isinf" <> parens (castToDouble double) ] +ppExternal binds "isDoubleNegativeZero" tys [double, realWorld] + = mkBind binds [ ppRenamed realWorld + , int 0 ] +ppExternal binds "isFloatNaN" tys [double, realWorld] + = mkBind binds [ ppRenamed realWorld + , text "isnan" <> parens (castToDouble double) ] +ppExternal binds "isFloatInfinite" tys [double, realWorld] + = mkBind binds [ ppRenamed realWorld + , text "isinf" <> parens (castToDouble double) ] +ppExternal binds "isFloatNegativeZero" tys [double, realWorld] + = mkBind binds [ ppRenamed realWorld + , int 0 ] +ppExternal binds fn tys args + = if returnType == UnitType + then mkBind binds [ ppRenamed (last args) ] <$$> + text fn <> argList <> semi + else mkBind binds [ ppRenamed (last args) + , text fn <> argList ] + where argList = parens $ hsep $ punctuate comma $ map ppRenamed (init args) + returnType = last tys + +ppFunctionCall binds fn args + = vsep $ [ ppRenamed fn <> argList <> semi ] ++ + if isTailCall then [] else [ mkBind binds (map (ppRenamed.cafName) returnArguments) ] + where argList = parens $ hsep $ punctuate comma $ map ppRenamed args + isTailCall = and (zipWith (==) binds (map cafName returnArguments)) + +{- +-- More than one bind can occur in case expressions. Just take the first. +ppExpression (bind:_) (Constant (Lit (Lrational r))) + = bind =: castToWord (double (fromRational r)) <> semi +ppExpression (bind:_) (Constant value) + = bind =: valueToDoc value +ppExpression [bind] (Application (Builtin "realWorld#") []) + = bind =: int 0 +ppExpression binds (Application fn args) | not (isBuiltin fn) && not (isExternal fn) && isTailCall + = ppRenamed fn <> argList <> semi + where argList = parens $ hsep $ punctuate comma $ map ppRenamed args + isTailCall = and (zipWith (==) binds (map cafName returnArguments)) +ppExpression binds (Application fn args) | not (isBuiltin fn) && not (isExternal fn) + = ppRenamed fn <> argList <> semi <$$> + vsep (zipWith (=:) binds (map (ppRenamed.cafName) returnArguments)) + where argList = parens $ hsep $ punctuate comma $ map ppRenamed args +ppExpression (bind:_) (Fetch nth variable) + = bind =: (ppRenamed variable <> brackets (int nth)) +ppExpression binds (Unit variables) + = vsep (zipWith (=:) binds (map ppRenamed variables)) +ppExpression [bind] (StoreHole size) + = vsep $ [ bind =: alloc (int $ max 4 size * 8)] +ppExpression (bind:_) (Store variables) + = vsep $ [ bind =: alloc (int $ (max 4 (length variables)) * 8)] ++ + [ writeArray bind n var | (n,var) <- zip [0..] variables ] +ppExpression binds (Case scrut alts) + = ppCase binds scrut alts +ppExpression binds (a :>>= binds' :-> b) + = declareVars binds' <$$> + ppExpression binds' a <$$> + ppExpression binds b + +ppExpression (bind:_) (Application (Builtin "coerceDoubleToWord") [arg]) + = bind =: ppRenamed arg +ppExpression (bind:_) (Application (Builtin "coerceWordToDouble") [arg]) + = bind =: ppRenamed arg +ppExpression (bind:_) (Application (Builtin "uncheckedShiftL#") [w,i]) + = bind =: (parens (cu32 <> ppRenamed w <+> text "<<" <+> cs32 <> ppRenamed i)) +ppExpression (bind:_) (Application (Builtin "uncheckedShiftRL#") [w,i]) + = bind =: (parens (cu32 <> ppRenamed w <+> text ">>" <+> cs32 <> ppRenamed i)) +ppExpression (bind:_) (Application (Builtin "noDuplicate#") [arg]) + = bind =: ppRenamed arg +ppExpression (bind:_) (Application (Builtin "==#") [a,b]) + = ifStatement (csunit <> ppRenamed a <+> text "==" <+> csunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "gtWord#") [a,b]) + = ifStatement (cunit <> ppRenamed a <+> text ">" <+> cunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "geWord#") [a,b]) + = ifStatement (cunit <> ppRenamed a <+> text ">=" <+> cunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "eqWord#") [a,b]) + = ifStatement (cunit <> ppRenamed a <+> text "==" <+> cunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "neWord#") [a,b]) + = ifStatement (cunit <> ppRenamed a <+> text "!=" <+> cunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "leWord#") [a,b]) + = ifStatement (cunit <> ppRenamed a <+> text "<=" <+> cunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "ltWord#") [a,b]) + = ifStatement (cunit <> ppRenamed a <+> text "<" <+> cunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "/=#") [a,b]) + = ifStatement (csunit <> ppRenamed a <+> text "!=" <+> csunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin ">#") [a,b]) + = ifStatement (csunit <> ppRenamed a <+> text ">" <+> csunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin ">=#") [a,b]) + = ifStatement (csunit <> ppRenamed a <+> text ">=" <+> csunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "<=#") [a,b]) + = ifStatement (csunit <> ppRenamed a <+> text "<=" <+> csunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "<#") [a,b]) + = ifStatement (csunit <> ppRenamed a <+> text "<" <+> csunit <> ppRenamed b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "<##") [a,b]) + = ifStatement (castToDouble a <+> text "<" <+> castToDouble b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "<=##") [a,b]) + = ifStatement (castToDouble a <+> text "<=" <+> castToDouble b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin ">=##") [a,b]) + = ifStatement (castToDouble a <+> text ">=" <+> castToDouble b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin ">##") [a,b]) + = ifStatement (castToDouble a <+> text ">" <+> castToDouble b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "==##") [a,b]) + = ifStatement (castToDouble a <+> text "==" <+> castToDouble b) + (bind =: int 1) + (bind =: int 0) +ppExpression (bind:_) (Application (Builtin "and#") [a,b]) + = bind =: parens (parens (cunit <> ppRenamed a) <+> text "&" <+> parens (cunit <> ppRenamed b)) +ppExpression (bind:_) (Application (Builtin "or#") [a,b]) + = bind =: parens (parens (cunit <> ppRenamed a) <+> text "|" <+> parens (cunit <> ppRenamed b)) +ppExpression (bind:_) (Application (Builtin "xor#") [a,b]) + = bind =: parens (parens (cunit <> ppRenamed a) <+> text "^" <+> parens (cunit <> ppRenamed b)) +ppExpression (bind:_) (Application (Builtin "not#") [a]) + = bind =: parens (text "~" <> parens (cunit <> ppRenamed a)) +ppExpression (bind:_) (Application (Builtin "ord#") [a]) + = bind =: ppRenamed a +ppExpression (bind:_) (Application (Builtin "chr#") [a]) + = bind =: ppRenamed a +ppExpression (bind:_) (Application (Builtin "negateInt#") [a]) + = bind =: (text "-" <+> csunit <+> cunit <> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "negateDouble#") [a]) + = bind =: castToWord (text "-" <+> castToDouble a) +ppExpression (bind:_) (Application (Builtin "narrow8Word#") [a]) + = bind =: (cunit <+> cu8 <+> cunit <+> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "narrow16Word#") [a]) + = bind =: (cunit <+> cu16 <+> cunit <+> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "narrow32Word#") [a]) + = bind =: (cunit <+> cu32 <+> cunit <+> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "narrow8Int#") [a]) + = bind =: (cunit <+> cs8 <+> cunit <+> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "narrow16Int#") [a]) + = bind =: (cunit <+> cs16 <+> cunit <+> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "narrow32Int#") [val]) + = bind =: (cunit <+> cs32 <+> cunit <+> ppRenamed val) +ppExpression (bind:_) (Application (Builtin "timesWord#") [a,b]) + = bind =: parens (cunit <+> ppRenamed a <+> text "*" <+> cunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "plusWord#") [a,b]) + = bind =: parens (cunit <+> ppRenamed a <+> text "+" <+> cunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "minusWord#") [a,b]) + = bind =: parens (cunit <+> ppRenamed a <+> text "-" <+> cunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "*#") [a,b]) + = bind =: parens (csunit <+> ppRenamed a <+> text "*" <+> csunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "*##") [a,b]) + = bind =: castToWord (castToDouble a <+> text "*" <+> castToDouble b) +ppExpression (bind:_) (Application (Builtin "-##") [a,b]) + = bind =: castToWord (castToDouble a <+> text "-" <+> castToDouble b) +ppExpression (bind:_) (Application (Builtin "+##") [a,b]) + = bind =: castToWord (castToDouble a <+> text "+" <+> castToDouble b) +ppExpression (bind:_) (Application (Builtin "/##") [a,b]) + = bind =: castToWord (castToDouble a <+> text "/" <+> castToDouble b) +ppExpression (bind:_) (Application (Builtin "**##") [a,b]) + = bind =: castToWord (text "pow" <> parens (castToDouble a <+> text "," <+> castToDouble b)) +ppExpression (bind:_) (Application (Builtin "sinDouble#") [a]) + = bind =: castToWord (text "sin" <> parens (castToDouble a)) +ppExpression (bind:_) (Application (Builtin "cosDouble#") [a]) + = bind =: castToWord (text "cos" <> parens (castToDouble a)) +ppExpression (bind:_) (Application (Builtin "sqrtDouble#") [a]) + = bind =: castToWord (text "sqrt" <> parens (castToDouble a)) +ppExpression (bind:_) (Application (Builtin "logDouble#") [a]) + = bind =: castToWord (text "log" <> parens (castToDouble a)) +ppExpression (bind:_) (Application (Builtin "expDouble#") [a]) + = bind =: castToWord (text "exp" <> parens (castToDouble a)) +ppExpression (bind:_) (Application (Builtin "int2Double#") [a]) + = bind =: castToWord (parens (text "double") <> cunit <> ppRenamed a) +ppExpression (bind:_) (Application (Builtin "double2Int#") [a]) + = bind =: (cunit <> castToDouble a) +ppExpression (bind:_) (Application (Builtin "+#") [a,b]) + = bind =: parens (csunit <+> ppRenamed a <+> text "+" <+> csunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "-#") [a,b]) + = bind =: parens (csunit <+> ppRenamed a <+> text "-" <+> csunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "quotInt#") [a,b]) + = bind =: parens (csunit <+> ppRenamed a <+> text "/" <+> csunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "quotWord#") [a,b]) + = bind =: parens (cunit <+> ppRenamed a <+> text "/" <+> cunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "remInt#") [a,b]) + = bind =: parens (csunit <+> ppRenamed a <+> text "%" <+> csunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "remWord#") [a,b]) + = bind =: parens (cunit <+> ppRenamed a <+> text "%" <+> cunit <+> ppRenamed b) +ppExpression (bind:_) (Application (Builtin "indexCharOffAddr#") [addr,idx]) + = bind =: (cunit <+> parens (cu8p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx)) +ppExpression (st:bind:_) (Application (Builtin "readCharArray#") [arr,idx,realWorld]) + = vsep [ bind =: (cunit <+> parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx)) + , st =: ppRenamed realWorld ] +ppExpression (st:_) (Application (Builtin "writeArray#") [arr, idx, elt, realWorld]) + = vsep [ st =: ppRenamed realWorld + , ppRenamed arr <> brackets (cunit <> ppRenamed idx) <+> equals <+> cunit <> ppRenamed elt <> semi + ] +ppExpression (st:bind:_) (Application (Builtin "readArray#") [arr, idx, realWorld]) + = vsep [ st =: ppRenamed realWorld + , bind =: (ppRenamed arr <> brackets (cunit <+> ppRenamed idx)) + ] +ppExpression (bind:_) (Application (Builtin "indexArray#") [arr, idx]) + = vsep [ bind =: (ppRenamed arr <> brackets (cunit <> ppRenamed idx)) ] +ppExpression (st:_) (Application (Builtin "writeCharArray#") [arr,idx,chr,realWorld]) + = vsep [ parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+> + equals <+> cu8 <+> cunit <+> ppRenamed chr <> semi + , st =: ppRenamed realWorld ] +ppExpression (st:_) (Application (Builtin "writeWord8Array#") [arr,idx,word,realWorld]) + = vsep [ parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+> + equals <+> cu8 <+> cunit <+> ppRenamed word <> semi + , st =: ppRenamed realWorld ] +ppExpression (st:_) (Application (Builtin "writeWord8OffAddr#") [arr,idx,word,realWorld]) + = vsep [ parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+> + equals <+> cu8 <+> cunit <+> ppRenamed word <> semi + , st =: ppRenamed realWorld ] +ppExpression (st:_) (Application (Builtin "writeInt8OffAddr#") [arr,idx,word,realWorld]) + = vsep [ parens (cs8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+> + equals <+> cs8 <+> cunit <+> ppRenamed word <> semi + , st =: ppRenamed realWorld ] +ppExpression (st:_) (Application (Builtin "writeDoubleOffAddr#") [arr,idx,double,realWorld]) + = vsep [ parens (cunitp <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+> + equals <+> cunit <+> ppRenamed double <> semi + , st =: ppRenamed realWorld ] +ppExpression (st:bind:_) (Application (Builtin "readAddrOffAddr#") [addr, idx, realworld]) + = vsep [ bind =: (ppRenamed addr <> brackets (cunit <+> ppRenamed idx)) + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (Builtin "readDoubleOffAddr#") [addr, idx, realworld]) + = vsep [ bind =: (ppRenamed addr <> brackets (cunit <+> ppRenamed idx)) + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (Builtin "readInt32OffAddr#") [addr,idx, realworld]) + = vsep [ bind =: (cunit <+> parens (cs32p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx)) + , st =: ppRenamed realworld + ] +ppExpression (st:bind:_) (Application (Builtin "readWord8Array#") [addr,idx, realworld]) + = vsep [ bind =: (cunit <+> parens (cu8p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx)) + , st =: ppRenamed realworld + ] +ppExpression (st:bind:_) (Application (Builtin "readInt8OffAddr#") [addr,idx, realworld]) + = vsep [ bind =: (cunit <+> parens (cs8p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx)) + , st =: ppRenamed realworld + ] +ppExpression (st:bind:_) (Application (Builtin "unsafeFreezeByteArray#") [addr, realworld]) + = vsep [ bind =: ppRenamed addr + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (Builtin "unsafeFreezeArray#") [addr, realworld]) + = vsep [ bind =: ppRenamed addr + , st =: ppRenamed realworld ] +ppExpression (bind:_) (Application (Builtin "byteArrayContents#") [addr]) + = bind =: ppRenamed addr +ppExpression (st:_) (Application (Builtin "touch#") [ptr,realworld]) + = st =: ppRenamed realworld + +ppExpression (st:bind:_) (Application (Builtin "mkWeak#") [key, val, finalizer, realWorld]) + = vsep [ bind =: int 0 + , st =: ppRenamed realWorld ] +ppExpression (st:arr:_) (Application (Builtin "newArray#") [size, elt, realWorld]) + = vsep [ st =: ppRenamed realWorld + , arr =: alloc (cunit <> ppRenamed size <+> text "* 8") + , text "int " <> i <+> equals <+> text "0;" + , text "for(;" <> i <> text "<" <> cunit <> ppRenamed size <> text ";" <> i <> text"++) {" <$$> + text " " <> ppRenamed arr <> brackets i <+> equals <+> ppRenamed elt <> semi <$$> + text "}" + ] + where i = text "i_" <> ppRenamed arr +ppExpression (st:arr:_) (Application (Builtin "newByteArray#") [size,realWorld]) + = vsep [ st =: ppRenamed realWorld + , arr =: alloc (cunit <+> ppRenamed size) ] +ppExpression (st:arr:_) (Application (Builtin "newPinnedByteArray#") [size,realWorld]) + = vsep [ st =: ppRenamed realWorld + , arr =: alloc (cunit <+> ppRenamed size) ] +-- FIXME: The ByteArray isn't aligned. +ppExpression (st:arr:_) (Application (Builtin "newAlignedPinnedByteArray#") [size,alignment,realWorld]) + = vsep [ st =: ppRenamed realWorld + , arr =: alloc (cunit <+> ppRenamed size) ] +ppExpression _ (Application (Builtin "update") (ptr:values)) + = vsep [ writeArray ptr n value | (n,value) <- zip [0..] values ] +ppExpression (st:_) (Application (Builtin "updateMutVar") [ptr,val,realWorld]) + = vsep [ writeArray ptr 0 val + , st =: ppRenamed realWorld ] +ppExpression (st:bind:_) (Application (External "fdReady") args) + = vsep [ bind =: int 1 + , st =: ppRenamed (last args) ] +ppExpression (st:bind:_) (Application (External "isDoubleNegativeZero") [double,realworld]) + = vsep [ bind =: int 0 + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (External "isFloatNegativeZero") [double,realworld]) + = vsep [ bind =: int 0 + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (External "isDoubleNaN") [double,realworld]) + = vsep [ bind =: (text "isnan" <> parens (castToDouble double)) + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (External "isDoubleInfinite") [double,realworld]) + = vsep [ bind =: (text "isinf" <> parens (castToDouble double)) + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (External "isFloatNaN") [double,realworld]) + = vsep [ bind =: (text "isnan" <> parens (castToDouble double)) + , st =: ppRenamed realworld ] +ppExpression (st:bind:_) (Application (External "isFloatInfinite") [double,realworld]) + = vsep [ bind =: (text "isinf" <> parens (castToDouble double)) + , st =: ppRenamed realworld ] +ppExpression (st:_) (Application (External "getProgArgv") [argcPtr, argvPtr, realWorld]) + = vsep [ parens (parens (text "int*") <>ppRenamed argcPtr) <> brackets (int 0) <+> equals <+> text "global_argc" <> semi + , ppRenamed argvPtr <> brackets (int 0) <+> equals <+> text "global_argv" <> semi + , st =: ppRenamed realWorld ] +ppExpression (st:bind:_) (Application (External "__hscore_get_errno") args) + = vsep [ bind =: (cunit <+> text "errno") + , st =: ppRenamed (last args) ] +ppExpression (st:bind:_) (Application (External "__hscore_PrelHandle_write") [fd,ptr,offset,size,realWorld]) + = vsep [ bind =: (text "write" <> parens (hsep $ punctuate comma $ [ cunit <+> ppRenamed fd + , ppRenamed ptr <+> text "+" <+> cunit <+> ppRenamed offset + , ppRenamed size])) + , st =: ppRenamed realWorld ] +ppExpression (st:bind:_) (Application (External "__hscore_memcpy_dst_off") [dst, off, src, size, realWorld]) + = vsep [ bind =: (text "memcpy" <> parens (hsep $ punctuate comma $ [ cunit <+> ppRenamed dst <+> text "+" <+> cunit <+> ppRenamed off + , ppRenamed src + , ppRenamed size ])) + , st =: ppRenamed realWorld ] +ppExpression (st:bind:_) (Application (External fn) args) + = vsep [bind =: (text fn <> argList) + ,st =: ppRenamed (last args) ] + where argList = parens $ hsep $ punctuate comma $ map ppRenamed (init args) + +ppExpression binds e = panic (show (Grin.ppExpression e)) +-} + +castToWord double + = text "doubleToWord" <> parens double +castToDouble ptr + = text "wordToDouble" <> parens (ppRenamed ptr) + +ppCase binds scrut alts + = switch (cunit <+> ppRenamed scrut) $ + vsep (map ppAlt alts) <$$> def (last alts) + where def (Empty :> _) = empty + def _ = text "default:" <$$> indent 2 (panic ("No match for case: " ++ show scrut)) + ppAlt (value :> exp) + = case value of + Empty + -> text "default:" <$$> braces rest + Node tag _nt _missing + -> text "case" <+> int (uniqueId tag) <> colon <$$> braces rest + Lit (Lint i) + -> text "case" <+> int (fromIntegral i) <> colon <$$> braces rest + Lit (Lchar c) + -> text "case" <+> int (ord c) <> colon <$$> braces rest + where rest = indent 2 ({-cafName (head returnArguments) =: ppRenamed (cafName (head returnArguments)) <$$>-} + ppExpression binds exp <$$> + text "break;") + +valueToDoc :: Value -> Doc +valueToDoc (Node tag nt missing) = int (uniqueId tag) +valueToDoc (Lit (Lint i)) = int (fromIntegral i) +valueToDoc (Lit (Lchar c)) = int (ord c) +valueToDoc (Lit (Lrational r)) = castToWord (double (fromRational r)) +valueToDoc val = error $ "Grin.Stage2.Backend.C.valueToDoc: Can't translate: " ++ show val + + + + +{- +primOps = Map.fromList [ "==##" +> \ ~[bind] [a,b] -> + ifStatement (castToDouble a <+> text "==" <+> castToDouble b) + (bind =: int 1) + (bind =: int 0) + ] + where (+>) = (,) +-} + + + + + + + + + +panic :: String -> Doc +panic txt = text "panic" <> parens (escString txt) <> semi + +alloc :: Doc -> Doc +--alloc size = text "GC_MALLOC" <> parens (size) +alloc size = text "alloc" <> parens (size) + +writeArray :: Renamed -> Int -> Renamed -> Doc +writeArray arr nth val + = ppRenamed arr <> brackets (int nth) <+> equals <+> cunit <+> ppRenamed val <> semi + +writeArray' :: Renamed -> Int -> Doc -> Doc +writeArray' arr nth val + = ppRenamed arr <> brackets (int nth) <+> equals <+> cunit <+> val <> semi + +(=:) :: Renamed -> Doc -> Doc +variable =: value = ppRenamed variable <+> equals <+> cunitp <+> value <> semi + +declareVar :: Renamed -> Doc +declareVar var + = unit <> char '*' <+> ppRenamed var <> semi + +declareVars :: [Renamed] -> Doc +declareVars = vsep . map declareVar + +escString :: String -> Doc +escString string = char '"' <> text (concatMap worker string) <> char '"' + where worker c | False = [c] + | otherwise = printf "\\x%02x" (ord c) + +initList :: [Int] -> Doc +initList vals = braces $ hsep $ punctuate comma $ map int vals + +switch ::Doc -> Doc -> Doc +switch scrut body + = text "switch" <> parens scrut <+> char '{' <$$> + indent 2 body <$$> + char '}' + +ppRenamed :: Renamed -> Doc +ppRenamed (Anonymous i) + = text "anon_" <> int i +ppRenamed (Aliased i name) + = text "named_" <> sanitize name <> char '_' <> int i +ppRenamed (Builtin "undefined") + = text "0" +ppRenamed (Builtin builtin) + = error $ "Grin.Stage2.Backend.C.ppRenamed: Unknown primitive: " ++ show builtin + +sanitize :: CompactString -> Doc +sanitize cs = text (map sanitizeChar $ show $ pretty cs) + +sanitizeChar :: Char -> Char +sanitizeChar c | isAlphaNum c = c + | otherwise = '_' + +ifStatement :: Doc -> Doc -> Doc -> Doc +ifStatement cond true false + = text "if" <> parens cond <$$> + indent 2 (braces true) <$$> + text "else" <$$> + indent 2 (braces false) + +include :: FilePath -> Doc +include headerFile + = text "#include" <+> char '<' <> text headerFile <> char '>' + +comment :: String -> Doc +comment str = text "/*" <+> text str <+> text "*/" + + +typedef, unsigned, signed, long, void, u64, u32, u16, u8, s64, s32, s16,s8 :: Doc +typedef = text "typedef" +unsigned = text "unsigned" +signed = text "signed" +long = text "long" +void = text "void" +unit = text "unit" +unitp = text "unit*" +sunit = text "sunit" +sunitp = text "sunit*" +u64 = text "u64" +u32 = text "u32" +u16 = text "u16" +u8 = text "u8" +s64 = text "s64" +s32 = text "s32" +s16 = text "s16" +s8 = text "s8" + +cunit = parens unit +cunitp = parens unitp + +csunit = parens sunit +csunitp = parens sunitp + +cu64 = parens u64 +cu64p = parens (u64<>char '*') + +cu32 = parens u32 +cu32p = parens (u32<>char '*') + +cu16 = parens u16 +cu16p = parens (u16<>char '*') + +cu8 = parens u8 +cu8p = parens (u8<>char '*') + +cs64 = parens s64 +cs64p = parens (s64<>char '*') + +cs32 = parens s32 +cs32p = parens (s32<>char '*') + +cs16 = parens s16 +cs16p = parens (s16<>char '*') + +cs8 = parens s8 +cs8p = parens (s8<>char '*') + + + diff --git a/src/Grin/Stage2/Backend/LLVM.hs b/src/Grin/Stage2/Backend/LLVM.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Backend/LLVM.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE OverloadedStrings #-} +module Grin.Stage2.Backend.LLVM ( compile ) where + +import qualified Grin.Stage2.Types as Grin +import Grin.Stage2.Types +import CompactString + +import Control.Monad.State +import Control.Monad.Reader +import System.FilePath +import System.Directory +import Text.PrettyPrint.ANSI.Leijen hiding ((), (<$>)) +import qualified Data.Map as Map +import Data.Char +import Text.Printf +import Control.Applicative hiding (empty) + +import Paths_lhc + +type Scope = Map.Map Renamed LLVMValue + +data LLVMValue = Local String | Global String | StringGlobal String + +compile :: Grin -> FilePath -> IO () +compile grin target + = do rts <- getDataFileName ("rts" "rts.ll") + let llvmTarget = replaceExtension target "ll" + copyFile rts llvmTarget + appendFile llvmTarget (show (grinToLLVM grin)) + +grinToLLVM :: Grin -> Doc +grinToLLVM grin = runReader (toLLVM grin) grin + +type M a = Reader Grin a + +toLLVM :: Grin -> M Doc +toLLVM grin + = do cafs <- vsep <$> mapM cafToLLVM (grinCAFs grin) + funcs <- vsep <$> mapM funcDefToLLVM (grinFunctions grin) + return $ vsep [ comment "CAFs:" + , cafs + , comment "Functions:" + , funcs ] + +cafToLLVM :: CAF -> M Doc +cafToLLVM CAF{cafName = name, cafValue = Lit (Lstring str)} + = return $ text "@" <> ppRenamed name <+> equals <+> stringConstant (str++"\0") +cafToLLVM CAF{cafName = name, cafValue = Node{}} + = return $ text "@" <> ppRenamed name <+> equals <+> global <+> unitp <+> zeroinitializer +cafToLLVM caf = return $ comment "FIXME: cafToLLVM" + +funcDefToLLVM :: FuncDef -> M Doc +funcDefToLLVM func + = body >>= \body' -> return $ + define <+> void <+> char '@' <> ppRenamed (funcDefName func) <> parens argList <+> lbrace <$$> + indent 2 ( rets <$$> body' <$$> exit) <$$> + rbrace + where retArg n = char '%' <> text "ret_" <> int n + rets = vsep [ retArg n <+> equals <+> call <+> unitp <+> text "@getReturnValuePtr" <> parens (i32 <+> int n ) | n <- [0.. funcDefReturns func - 1] ] + body = expressionToLLVM (map retArg [0 .. funcDefReturns func - 1]) (funcDefBody func) + exit = ret <+> void + argList = hang 0 $ sep $ punctuate comma [ unitp <+> char '%' <> ppRenamed arg | arg <- funcDefArgs func ] +{- +data LLVMDecl + = LLVMGlobal Renamed + | LLVMConstant Renamed String + | LLVMFunction Renamed [LLVMVar] + +data LLVMVar + = LLVMLocal Renamed + | LLVMGlobal Renamed + | LLVMGlobalString Renamed + +data LLVMStmt + = LLVMStore LLVMVar LLVMVar + | LLVMBind LLVMVar LLVMExpression + | LLVMComment String +data LLVMExpression + = LLVMLoad LLVMVar + | LLVMAlloca LLVMType +-} +expressionToLLVM :: [Doc] -> Expression -> M Doc +expressionToLLVM binds exp + = case exp of + Constant (Lit (Lint i)) -> return $ storeUnit (int $ fromIntegral i) (head binds) + a :>>= binds' :-> b -> do let llvmBinds = [ char '%' <> ppRenamed var | var <- binds' ] + a' <- expressionToLLVM llvmBinds a + b' <- expressionToLLVM binds b + return $ vsep [ var <+> equals <+> alloca unit | var <- llvmBinds ] <$$> + a' <$$> b' + Unit vars -> return $ vsep [ ppTemp bind (ppRenamed var) <+> equals <+> text "load" <+> unitp <+> char '%' <> ppRenamed var <$$> + storeUnit (ppTemp bind (ppRenamed var)) bind + | (var,bind) <- zip vars binds ] + Application (Builtin "realWorld#") [] + -> return $ storeUnit (int 0) (head binds) + Application (Builtin "unreachable") [] + -> return $ text "unreachable" + Application fn args | not (isBuiltin fn) && not (isExternal fn) + -> let argList = hang 0 $ sep $ punctuate comma $ [ unitp <+> char '%' <> ppRenamed arg | arg <- args ] + in return $ call <+> void <+> char '@' <> ppRenamed fn <> parens argList + _ -> return $ comment "FIXME: expressionToLLVM" + +------------------------------------------------------------- +-- Utilities + +storeUnit val ptr = text "store" <+> unit <+> val <> text "," <+> unitp <+> ptr +alloca ty = text "alloca" <+> ty + +ppTemp a b = char '%' <> text "tmp_" <> text (drop 1 $ show a) <> b +comment str = char ';' <+> text str + +ret = text "ret" +void = text "void" +define = text "define" +call = text "call" +i32 = text "i32" +i32p = text "i32*" +unit = text "%unit" +unitp = text "%unit*" +global = text "global" +zeroinitializer = text "zeroinitializer" + +stringConstant str + = internal <+> constant <+> strType <+> char 'c' <> dquotes (escString str) + where strType = brackets (int (length str) <+> char 'x' <+> text "i8") + internal = text "internal" + constant = text "constant" + +escString :: String -> Doc +escString string = text (concatMap worker string) + where worker c | isPrint c = [c] + | otherwise = printf "\\%02x" (ord c) + +ppRenamed :: Renamed -> Doc +ppRenamed (Anonymous i) + = text "anon_" <> int i +ppRenamed (Aliased i name) + = text "named_" <> sanitize name <> char '_' <> int i +ppRenamed (Builtin "undefined") + = text "0" +ppRenamed (Builtin builtin) + = error $ "Grin.Stage2.Backend.LLVM.ppRenamed: Unknown primitive: " ++ show builtin + +sanitize :: CompactString -> Doc +sanitize cs = text (map sanitizeChar $ show $ pretty cs) + +sanitizeChar :: Char -> Char +sanitizeChar c | isAlphaNum c = c + | otherwise = '_' + +{- +data Var + = GlobalVar Renamed Type + | LocalVar Int Type + | IntConstant Int Type + | StrConstant String Type + +varType :: Var -> Type +varType (GlobalVar _name ty) = ty +varType (LocalVar _ident ty) = ty +varType (IntConstant _val ty) = ty +varType (StrConstant _str ty) = ty + +data Type + = Word + | I8 + | Pointer Type + | Array Int Type + | Struct [Type] + | Named String + deriving (Show) + +-- ret type +data Function + = Function Renamed [Var] [Statement] + +data Statement + = Assignment Var Expression + | Comment String + | VoidCall Renamed [Var] + | Ret Var + | RetVoid + | RetArray Type [Var] + | RetStruct [Var] + | Store Var Var +data Expression + = BinOp Var BinOp Var + | Cast Var Type + | Load Var + | Call Type Renamed [Var] + | GetElementPtr Type Var [Int] + | ExtractValue Type Var Int + +data BinOp + = Add + | Shl + | Shr + | And + | Or + +data Module + = Module { moduleGlobals :: [(Var, Value)] + , moduleFunctions :: [Function] + } + +type Scope = Map.Map Renamed Var +type ReturnArity = Map.Map Renamed Int +type M a = ReaderT (Scope, ReturnArity) (State Int) a + +fixedSize :: Int +fixedSize = 10 + +memT :: Type +memT = Named "mem" + +returnArgs = [ GlobalVar (Anonymous n) (Pointer Word) | n <- [1..10] ] + + +fromGrin :: Grin.Grin -> Module +fromGrin grin + = let scope = (Map.empty, returnArity) + returnArity = Map.fromList [ (funcDefName func, funcDefReturns func) | func <- grinFunctions grin ] + unique = grinUnique grin + genFunctions = extendScope (zip (map cafName (grinCAFs grin)) cafVars) $ + mapM fromFuncDef (grinFunctions grin) + functions = evalState (runReaderT genFunctions scope) unique + cafVars = [ GlobalVar (cafName caf) (Pointer memT) | caf <- grinCAFs grin ] + in Module { moduleGlobals = [ (GlobalVar (cafName caf) memT, uniqueId (cafName caf):replicate (fixedSize-1) 0 ) | caf <- grinCAFs grin] + , moduleFunctions = functions + } + +fromFuncDef :: FuncDef -> M Function +fromFuncDef funcDef + = do args' <- replicateM (length (funcDefArgs funcDef)) (newVariable Word) + extendScope (zip (funcDefArgs funcDef) args') $ + do rets <- replicateM (funcDefReturns funcDef) $ newVariable Word + let setReturnArgs = [ Store ret var | (var, ret) <- zip returnArgs rets] + stmts <- fromExpression rets (funcDefBody funcDef) + return $ Function (funcDefName funcDef) args' (stmts ++ setReturnArgs ++ [RetVoid]) + +fromExpression :: [Var] -> Grin.Expression -> M [Statement] +fromExpression [bind] (Grin.Constant value) + = return [Assignment bind (valueToExpression (varType bind) value)] + +fromExpression [bind] (Grin.Application (Builtin "realWorld#") []) + = return [Assignment bind $ Cast (IntConstant 0 Word) (varType bind)] + +fromExpression [bind] (Grin.Fetch nth renamed) + = do var <- lookupVariable renamed + castedVar <- newVariable (Pointer Word) + ptrVar <- newVariable (Pointer Word) + return [ Comment $ show $ text "fetch" <> brackets (int nth) <+> ppRenamed renamed + , Assignment castedVar $ Cast var (Pointer Word) + , Assignment ptrVar $ GetElementPtr (varType castedVar) castedVar [nth] + , Assignment bind (Load ptrVar) + ] + +fromExpression binds (Grin.Application fn args) | not (isBuiltin fn) && not (isExternal fn) + = do arity <- lookupReturnArity fn + args' <- mapM lookupVariable args + let funcType = Struct (replicate arity Word) + return $ [ VoidCall fn args' ] ++ + [ Assignment bind $ Load var | (var,bind) <- zip returnArgs binds ] + + +fromExpression binds (a Grin.:>>= binds' Grin.:-> b) + = do args <- replicateM (length binds') $ newVariable Word + a' <- fromExpression args a + extendScope (zip binds' args) $ + do b' <- fromExpression binds b + return (a' ++ b') +fromExpression _binds _ = return [] + +valueToExpression :: Type -> Grin.Value -> Expression +valueToExpression ty (Lit (Lint i)) = Cast (IntConstant (fromIntegral i) Word) ty +valueToExpression ty (Lit (Lchar c)) = Cast (IntConstant (ord c) Word) ty +valueToExpression ty (Lit (Lstring s)) = Cast (StrConstant s (Array (length s + 1) I8)) ty +valueToExpression ty (Node tag nt missing) + = Cast (IntConstant (uniqueId tag) Word) ty +valueToExpression ty (Empty) + = Cast (IntConstant 0 Word) ty +valueToExpression ty (Hole) + = Cast (IntConstant 0 Word) ty + + + +extendScope :: [(Renamed, Var)] -> M a -> M a +extendScope assocs + = local $ \(scope,returnArity) -> (Map.fromList assocs `Map.union` scope, returnArity) + +newVariable :: Type -> M Var +newVariable ty + = do u <- get + put (u+1) + return $ LocalVar u ty + +lookupVariable :: Renamed -> M Var +lookupVariable variable + = asks $ Map.findWithDefault errMsg variable . fst + where errMsg = error $ "Grin.Stage2.Backend.LLVM.lookupVariable: couldn't find key: " ++ show variable + +lookupReturnArity :: Renamed -> M Int +lookupReturnArity function + = asks $ Map.findWithDefault errMsg function . snd + where errMsg = error $ "Grin.Stage2.Backend.LLVM.lookupReturnArity: couldn't find key: " ++ show function + + + + + + + + +ppModule :: Module -> Doc +ppModule llvmModule + = ppNamedType "mem" (Array fixedSize Word) <$$> + ppComment "return arguments:" <$$> + vsep (map ppReturnArg returnArgs) <$$> + ppComment "CAFs:" <$$> + vsep (map ppGlobal (moduleGlobals llvmModule)) <$$> + ppComment "Functions:" <$$> + vsep (map ppFunction (moduleFunctions llvmModule)) + +ppFunction :: Function -> Doc +ppFunction (Function name args stmts) + = text "define" <+> text "void" <+> char '@' <> ppRenamed name <> + parens (hsep (punctuate comma [ppType (varType var) <+> ppVar var | var <- args])) <+> + braces (linebreak <> + indent 2 (vsep $ map ppStatement stmts) <> + linebreak) + +ppStatement :: Statement -> Doc +ppStatement (Ret var) + = text "ret" <+> ppType (varType var) <+> ppVar var +ppStatement (RetVoid) + = text "ret" <+> text "void" +ppStatement (RetArray ty vars) + = text "ret" <+> ppType ty <+> brackets (hsep $ punctuate comma $ [ ppType (varType var) <+> ppVar var | var <- vars]) +ppStatement (RetStruct vars) + = text "ret" <+> ppType (Struct (map varType vars)) <+> braces (hsep $ punctuate comma $ [ ppType (varType var) <+> ppVar var | var <- vars]) +ppStatement (Comment str) + = ppComment str +ppStatement (Assignment var exp) + = ppVar var <+> equals <+> ppExpression exp +ppStatement (VoidCall fn args) + = text "call" <+> text "void" <+> char '@' <> ppRenamed fn <> parens (hsep (punctuate comma $ [ppType (varType arg) <+> ppVar arg | arg <- args])) +ppStatement (Store var ptr) + = text "store" <+> ppType (varType var) <+> ppVar var <> comma <+> ppType (varType ptr) <+> ppVar ptr + +ppExpression (Cast var ty) + = case (varType var, ty) of + (Pointer{}, Pointer{}) -> bitcast + (Pointer{}, _) -> ptrtoint + (_, Pointer{}) -> inttoptr + _ -> bitcast + where bitcast = text "bitcast" <+> ppType (varType var) <+> ppVar var <+> text "to" <+> ppType ty + ptrtoint = text "ptrtoint" <+> ppType (varType var) <+> ppVar var <+> text "to" <+> ppType ty + inttoptr = text "inttoptr" <+> ppType (varType var) <+> ppVar var <+> text "to" <+> ppType ty +ppExpression (Load ptr) + = text "load" <+> ppType (varType ptr) <+> ppVar ptr +ppExpression (BinOp a op b) + = ppBinOp op <+> ppType (varType a) <+> ppVar a <> comma <+> ppVar b +ppExpression (Call ty fn args) + = text "call" <+> ppType ty <+> char '@' <> ppRenamed fn <> parens (hsep (punctuate comma $ [ppType (varType arg) <+> ppVar arg | arg <- args])) +ppExpression (GetElementPtr ty var idx) + = text "getelementptr" <+> ppType ty <+> ppVar var <> comma <+> hsep (punctuate comma $ [ text "i32" <+> int nth | nth <- idx ]) +ppExpression (ExtractValue ty var idx) + = text "extractvalue" <+> ppType ty <+> ppVar var <> comma <+> int idx + +ppBinOp Add = text "add" + +ppNamedType :: String -> Type -> Doc +ppNamedType synonym ty + = char '%' <> text synonym <+> equals <+> text "type" <+> ppType ty + +ppComment :: String -> Doc +ppComment comment = char ';' <+> text comment + +ppReturnArg :: Var -> Doc +ppReturnArg var + = ppVar var <+> equals <+> text "global" <+> ppType Word <+> int 0 + +ppGlobal :: (Var,Value) -> Doc +ppGlobal (var,Node tag _nt _missing) + = ppVar var <+> equals <+> text "global" <+> ppType (varType var) <+> ppArray Word initValues + +ppArray :: Type -> [Int] -> Doc +ppArray ty vals = brackets (hsep $ punctuate comma $ [ ppType ty <+> int val | val <- vals ]) + +ppType :: Type -> Doc +ppType (Word) = text "i64" +ppType I8 = text "i8" +ppType (Pointer ty) = ppType ty <> char '*' +ppType (Array size eltType) + = brackets (int size <+> char 'x' <+> ppType eltType) +ppType (Struct tys) + = braces $ hsep $ punctuate comma $ map ppType tys +ppType (Named name) = char '%' <> text name + +ppVar :: Var -> Doc +ppVar (GlobalVar name _ty) = char '@' <> ppRenamed name +ppVar (LocalVar ident _ty) = char '%' <> text "local_" <> int ident +ppVar (IntConstant i _ty) = int i +ppVar (StrConstant str _ty) = char 'c' <> text (show str) + +ppRenamed :: Renamed -> Doc +ppRenamed renamed + = case alias renamed of + Just name -> text $ show name + Nothing -> text $ show $ show $ uniqueId renamed + +-} + + diff --git a/src/Grin/Stage2/DeadCode.hs b/src/Grin/Stage2/DeadCode.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/DeadCode.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, BangPatterns #-} +-- FIXME: Use HashSet instead of IntSet. +module Grin.Stage2.DeadCode + ( trimDeadCode + , calcLiveNodes + ) where + +import Grin.Stage2.Types + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Writer + +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import Debug.Trace + +calcLiveNodes :: Grin -> IO () +calcLiveNodes grin + = do let live = liveNodes grin + writeFile "livenodes.txt" (unlines (map show (IntSet.toList live))) + +trimDeadCode :: Grin -> Grin +trimDeadCode grin + = grin { grinFunctions = map walkFunc [ fn | fn <- grinFunctions grin, nodeId (funcDefName fn) `IntSet.member` liveSet] + , grinCAFs = [ caf | caf <- grinCAFs grin, nodeId (cafName caf) `IntSet.member` liveSet ] + , grinNodes = [ node | node <- grinNodes grin, nodeId (nodeName node) `IntSet.member` liveSet ] + } + where walkFunc func + = func { funcDefBody = walkExp (funcDefBody func) } + walkExp (e1@Case{} :>>= binds :-> e2) + = walkExp e1 :>>= binds :-> walkExp e2 + walkExp (e1@(Application (Builtin "update") args) :>>= binds :-> e2) | all isAlive args || True + = walkExp e1 :>>= binds :-> walkExp e2 + walkExp (e1 :>>= binds :-> e2) + = if all isDead binds + then walkExp e2 + else walkExp e1 :>>= binds :-> walkExp e2 + walkExp (Case scrut alts) + = if nodeId scrut `IntSet.member` liveSet || True + then Case scrut (map walkAlt alts) + else Unit [] + walkExp fn@(Application (Builtin "update") (ptr:_)) + | nodeId ptr `IntSet.member` liveSet || True + = fn + | otherwise + = Unit [] + walkExp fn = fn + walkAlt (alt :> exp) = alt :> walkExp exp + liveSet = liveNodes grin + isDead x = nodeId x `IntSet.notMember` liveSet + isAlive = not . isDead + +liveNodes :: Grin -> IntSet.IntSet +liveNodes grin + = let entryPoint = nodeId (grinEntryPoint grin) + graph = execSM (grinGraph grin) entryPoint IntMap.empty + in reachable entryPoint graph + +reachable :: Int -> DependencyGraph -> IntSet.IntSet +reachable entry graph + = loop (IntSet.singleton entry) (IntSet.singleton entry) + where loop marked new | IntSet.null new = marked + loop marked new + = let reachableByNew = IntSet.unions [ find node | node <- IntSet.toList new ] + unmarkedNew = reachableByNew `IntSet.difference` marked + in loop (marked `IntSet.union` unmarkedNew) unmarkedNew + find key = IntMap.findWithDefault IntSet.empty key graph + + + +newtype SM a = SM { runSM :: Int -> DependencyGraph -> (a, DependencyGraph) } + +instance Monad SM where + return x = SM $ \r s -> (x, s) + f >>= g = SM $ \r s -> case runSM f r s of + (a, !s') -> runSM (g a) r s' + +instance MonadState (IntMap.IntMap IntSet.IntSet) SM where + get = SM $ \_ s -> (s, s) + put s = SM $ \_ _ -> ((), s) + +instance MonadReader Int SM where + ask = SM $ \r s -> (r, s) + local fn m = SM $ \r s -> runSM m (fn r) s + +execSM action r s + = case runSM action r s of + (a, s) -> s + +type DependencyGraph = IntMap.IntMap IntSet.IntSet + +type M a = SM a + +top :: M Int +top = ask + +grinGraph :: Grin -> M () +grinGraph grin + = do mapM_ cafGraph (grinCAFs grin) + mapM_ funcGraph (grinFunctions grin) + +insert k v m = let v' = IntMap.findWithDefault IntSet.empty k m + in IntMap.insertWith IntSet.union k v m + +cafGraph :: CAF -> M () +cafGraph caf + = do let deps = valueGraph (cafValue caf) + modify $ insert (nodeId (cafName caf)) deps + return () + +funcGraph :: FuncDef -> M () +funcGraph func + = do bodyDeps <- local (const (nodeId (funcDefName func))) $ expGraph (funcDefBody func) + modify $ insert (nodeId (funcDefName func)) bodyDeps + return () + +expGraph :: Expression -> M IntSet.IntSet +expGraph (Unit vals) + = return $ IntSet.fromList (map nodeId vals) +expGraph (e1 :>>= binds :-> e2) + = do deps <- expGraph e1 + forM_ binds $ \bind -> modify $ insert (nodeId bind) deps + expGraph e2 +expGraph (Application (Builtin "updateMutVar") [ptr, val, realWorld]) + = do --modify $ insert (nodeId ptr) (IntSet.singleton (nodeId val)) + --modify $ insert (nodeId realWorld) (IntSet.singleton (nodeId ptr)) + return $ IntSet.fromList [nodeId realWorld, nodeId ptr, nodeId val] +expGraph (Application (Builtin "update") args) + = do t <- top + let s = IntSet.fromList (map nodeId args) + modify $ insert t s + return IntSet.empty +expGraph (Application fn args) + = return $ IntSet.fromList (map nodeId (fn:args)) +expGraph (Case scrut alts) + = do t <- top + modify $ insert t (IntSet.singleton (nodeId scrut)) + depss <- mapM altGraph alts + forM_ depss $ \deps -> + do modify $ insert (nodeId scrut) deps + forM_ (IntSet.toList deps) $ \dep -> + modify $ insert dep (IntSet.singleton (nodeId scrut)) + return $ IntSet.singleton (nodeId scrut) +expGraph (Fetch _idx hp) + = return $ IntSet.singleton (nodeId hp) +expGraph (Store vals) + = return $ IntSet.fromList (map nodeId vals) +expGraph (StoreHole _size) + = return IntSet.empty +expGraph (Constant value) + = return $ valueGraph value + +nodeId :: Renamed -> Int +nodeId (Aliased uid _name) = uid +nodeId (Anonymous uid) = uid +nodeId (Builtin{}) = -1 +nodeId (External{}) = -1 + +altGraph :: Alt -> M IntSet.IntSet +altGraph (value :> exp) + = IntSet.union (valueGraph value) `liftM` expGraph exp + +valueGraph :: Value -> IntSet.IntSet +valueGraph (Node tag ConstructorNode _partial) = IntSet.singleton (nodeId tag) +valueGraph (Node tag FunctionNode _partial) = IntSet.singleton (nodeId tag) +valueGraph Lit{} = IntSet.empty +valueGraph Hole = IntSet.empty +valueGraph Empty = IntSet.empty + diff --git a/src/Grin/Stage2/FromStage1.hs b/src/Grin/Stage2/FromStage1.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/FromStage1.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings #-} +module Grin.Stage2.FromStage1 + ( convert + ) where + +import qualified Grin.Types as Stage1 +import Grin.Stage2.Types as Stage2 + +import Grin.HPT + +import Control.Monad.RWS +import qualified Data.Map as Map +import Data.Monoid + +convert :: HeapAnalysis -> Stage1.Grin -> Stage2.Grin +convert hpt grin + = let initReader = (hpt,Map.empty) + initState = Stage1.grinUnique grin + convertFuncs = do nodes <- funcDefsToNodes (Stage1.grinFunctions grin) + withNodeMap nodes $ do funcs <- mapM convertFuncDef (Stage1.grinFunctions grin) + cafs <- mapM convertCAF (Stage1.grinCAFs grin) + return (funcs, cafs, nodes) + in case runRWS convertFuncs initReader initState of + ((funcs, cafs, nodes), newUnique, stringCAFs) + -> Grin { grinNodes = Stage1.grinNodes grin ++ + [ NodeDef name FunctionNode [] + | names <- Map.elems nodes + , name <- names ] + , grinCAFs = cafs ++ + [ CAF { cafName = name, cafValue = Lit (Lstring string) } + | (name, string) <- stringCAFs ] + , grinFunctions = funcs + , grinEntryPoint = Stage1.grinEntryPoint grin + , grinUnique = newUnique + } + +convertCAF :: Stage1.CAF -> M Stage2.CAF +convertCAF caf + = do value <- case Stage1.cafValue caf of + Stage1.Node tag nt missing _args -> do tag' <- lookupTag tag missing + return $ Node tag' nt missing + other -> error $ "Grin.Stage2.FromStage1.convertCaf: Weird caf: " ++ show other + return $ CAF { cafName = Stage1.cafName caf + , cafValue = value } + + +type NodeMap = Map.Map Renamed [Renamed] +type M a = RWS (HeapAnalysis,NodeMap) [(Renamed,String)] Int a + +funcDefToNode :: Stage1.FuncDef -> M (Renamed, [Renamed]) +funcDefToNode def + = do vars <- replicateM (arity+1) (newVariableFrom name) + return (name, vars) + where arity = length (Stage1.funcDefArgs def) + name = Stage1.funcDefName def + +funcDefsToNodes :: [Stage1.FuncDef] -> M NodeMap +funcDefsToNodes defs + = do nodes <- mapM funcDefToNode defs + return $ Map.fromList nodes + +withNodeMap :: NodeMap -> M a -> M a +withNodeMap nodes + = local (\(hpt,nodes') -> (hpt, Map.union nodes nodes')) + +convertFuncDef :: Stage1.FuncDef -> M Stage2.FuncDef +convertFuncDef def + = do body <- convertExpression (Stage1.funcDefBody def) + returns <- nodeSize (Stage1.funcDefName def) + return $ FuncDef { funcDefName = Stage1.funcDefName def + , funcDefReturns = returns + , funcDefArgs = Stage1.funcDefArgs def + , funcDefBody = body + } + +convertExpression :: Stage1.Expression -> M Stage2.Expression +convertExpression (Stage1.Application (Builtin "unreachable") [] Stage1.:>>= _) + = return $ Application (Builtin "unreachable") [] +convertExpression (a Stage1.:>>= v Stage1.:-> b) + = do a' <- convertExpression a + convertBind v $ \v' -> + do b' <- convertExpression b + return $ a' :>>= v' :-> b' +convertExpression (a Stage1.:>> b) + = do a' <- convertExpression a + b' <- convertExpression b + return $ a' :>>= [] :-> b' +convertExpression (Stage1.Application (Builtin "fetch") [p]) + = convertFetch p +convertExpression (Stage1.Update size ptr val) + = do [ptr'] <- lookupVariable ptr + values <- fmap (take size) $ lookupVariable val + if length values <= minNodeSize + then return $ Application fn (ptr':values) + else do extra <- newVariable + let (first,second) = splitAt (minNodeSize-1) values + return $ Store second :>>= [extra] :-> Application fn (ptr':first++[extra]) + where minNodeSize = 4 + fn = Builtin "update" +convertExpression (Stage1.Application fn args) + = do args' <- mapM lookupVariable args + return $ Application fn (map head args') +convertExpression (Stage1.Case scrut alts) + = do vector <- lookupVariable scrut + case vector of + [] -> return $ Application (Builtin "unreachable") [] + _ ->do alts' <- mapM (convertAlt vector) alts + return $ Case (head vector) alts' +convertExpression (Stage1.Store (Stage1.Hole size)) + = return $ StoreHole size +convertExpression (Stage1.Store val) + = convertValue worker val + where worker args + | length args <= minNodeSize + = return (Store args) + | otherwise + = do let (firstArgs, secondArgs) = splitAt (minNodeSize-1) args + extra <- newVariable + return $ Store secondArgs :>>= [extra] :-> Store (firstArgs++[extra]) + minNodeSize = 4 +convertExpression (Stage1.Unit val) + = convertValue (return . Unit) val + +convertBind :: Renamed -> ([Renamed] -> M a) -> M a +convertBind val fn + = do size <- nodeSize val + vars <- replicateM (max 1 size) newVariable + local (\(hpt,nmap) -> (hpt,Map.insert val vars nmap)) $ fn vars + + + +{- +do node <- fetch p + node `elem` [ Nil, Cons x y, NearBig x y z, Big x y z n ] +===> +do tag <- fetch 0 p + [x,y] <- case tag of + Nil -> do unit [] + Cons -> do x <- fetch 1 p + y <- fetch 2 p + unit [x,y] + NearBig -> do x <- fetch 1 p + y <- fetch 2 p + z <- fetch 3 p + unit [x,y,z] + Big -> do x <- fetch 1 p + y <- fetch 2 p + extra <- fetch 3 p + z <- fetch 0 extra + n <- fetch 1 extra + unit [x,y,z,n,i] +-} +convertFetch p + = do rhs <- heapNodeValues p + case rhs of + Other{rhsTagged = nodes} | not (Map.null nodes) + -> do let size = rhsSize rhs + [p'] <- lookupVariable p + v <- newVariable + tmps <- replicateM (size-1) newVariable + vars <- replicateM size newVariable + alts <- mapM (mkAlt p') (Map.toList nodes) + return $ Stage2.Fetch 0 p' :>>= [v] :-> Case v alts :>>= tmps :-> Unit (v:tmps) + Base + -> do [p'] <- lookupVariable p + return (Stage2.Fetch 0 p') + Heap _ + -> do [p'] <- lookupVariable p + return (Stage2.Fetch 0 p') + _ -> do return (Application (Builtin "unreachable") []) + where mkAlt p ((tag, nt, missing), args) + | length args <= minNodeSize-1 + = do argVars <- replicateM (length args) newVariable + let fetches = foldr (\(v,n) r -> Stage2.Fetch n p :>>= [v] :-> r) (Unit (argVars)) (zip argVars [1..]) + tag' <- lookupTag tag missing + return $ Node tag' nt missing :> fetches + | otherwise + = do argVars <- replicateM (length args) newVariable + extra <- newVariable + let (firstArgs, secondArgs) = splitAt (minNodeSize-2) argVars + firstFetches = foldr (\(v,n) r -> Stage2.Fetch n p :>>= [v] :-> r) secondFetches (zip firstArgs [1..]) + secondFetches = Stage2.Fetch (minNodeSize-1) p :>>= [extra] :-> + foldr (\(v,n) r -> Stage2.Fetch n extra :>>= [v] :-> r) (Unit argVars) (zip secondArgs [0..]) + tag' <- lookupTag tag missing + return $ Node tag' nt missing :> firstFetches + -- FIXME: The node size should be configurable. + minNodeSize = 4 + +nodeSize :: Renamed -> M Int +nodeSize val + = do hpt <- asks fst + return (rhsSize (lookupLhs (VarEntry val) hpt)) + +heapNodeSize :: Renamed -> M Int +heapNodeSize hp = do rhs <- heapNodeValues hp + return $ rhsSize rhs + +heapNodeValues :: Renamed -> M Rhs +heapNodeValues val + = do hpt <- asks fst + return (lookupHeap val hpt) + +find key m = Map.findWithDefault (error $ "Couldn't find key: " ++ show key) key m + +newVariable :: M Renamed +newVariable = newVariableFrom (Builtin "newVariable.undefined") + +newVariableFrom :: Renamed -> M Renamed +newVariableFrom original + = do u <- get + put (u+1) + return $ merge original $ Anonymous u + where merge (Aliased _ name) (Anonymous uid) = Aliased uid name + merge _ renamed = renamed + +convertAlt :: [Renamed] -> Stage1.Alt -> M Stage2.Alt +convertAlt vector (Stage1.Lit lit Stage1.:> alt) + = do alt' <- convertExpression alt + return $ Lit lit :> alt' +convertAlt vector (Stage1.Variable v Stage1.:> alt) + = convertBind v $ \v' -> + do alt' <- convertExpression alt + return $ Stage2.Empty :> Unit vector :>>= v' :-> alt' +convertAlt vector (Stage1.Node tag FunctionNode missing args Stage1.:> alt) + = do names <- lookupVariable tag + alt' <- convertExpression alt + return $ Node (names !! missing) FunctionNode missing :> Unit (tail vector) :>>= args :-> alt' +convertAlt vector (Stage1.Node tag nt missing args Stage1.:> alt) + = do alt' <- convertExpression alt + return $ Node tag nt missing :> Unit (tail vector) :>>= args :-> alt' +convertAlt vector (Stage1.Vector args Stage1.:> alt) + = do alt' <- convertExpression alt + return $ Stage2.Empty :> Unit vector :>>= args :-> alt' +convertAlt vector (Stage1.Empty Stage1.:> alt) + = error $ "Grin.Stage2.FromStage1.convertAlt: Empty case condition." +convertAlt vector (Stage1.Hole{} Stage1.:> alt) + = error $ "Grin.Stage2.FromStage1.convertAlt: Invalid case condition." + +convertValue :: ([Renamed] -> M Expression) -> Stage1.Value -> M Expression +convertValue fn (Stage1.Lit (Lstring string)) + = do v <- newVariable + tell [(v,string)] + fn [v] +convertValue fn (Stage1.Lit lit) = do v <- newVariable + r <- fn [v] + return $ Constant (Lit lit) :>>= [v] :-> r +convertValue fn Stage1.Hole{} = error "Grin.Stage2.FromStage1.convertValue: There shouldn't be a hole here." +convertValue fn (Stage1.Empty) = fn [] +convertValue fn (Stage1.Variable v) = fn =<< lookupVariable v +convertValue fn (Stage1.Node tag nt missing args) + = do tag' <- lookupTag tag missing + v <- newVariable + args' <- mapM lookupVariable args + r <- fn (v:concat args') + return $ Constant (Node tag' nt missing) :>>= [v] :-> r +convertValue fn (Stage1.Vector args) + = do args' <- mapM lookupVariable args + fn (concat args') + +lookupVariable :: Renamed -> M [Renamed] +lookupVariable val + = do nmap <- asks snd + return $ Map.findWithDefault [val] val nmap + +lookupTag :: Renamed -> Int -> M Renamed +lookupTag tag idx + = do tags <- lookupVariable tag + return (cycle tags !! idx) diff --git a/src/Grin/Stage2/Optimize/Case.hs b/src/Grin/Stage2/Optimize/Case.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Optimize/Case.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, NoMonomorphismRestriction #-} +module Grin.Stage2.Optimize.Case + ( optimize + , findRewriteRules + , RewriteRules(..) + , RewriteRule(..) + , applyRewriteRules + , inlinePass + ) where + +import Grin.Stage2.Types + +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.Map as Map +import Data.Maybe +import Grin.Stage2.Transform + +import Traverse +import Debug.Trace + + +optimize :: Grin -> Grin +optimize = runTrans (sequence_ [ transformExp' caseSplit + , transformExp caseLowering + , transformExp (return . promoteBottoms) + , runReaderT (transformExp storeFetch) Map.empty + ] + ) + +{- +do d <- case a of A -> b + B -> c + e +===> +fn args = e + +do case a of A -> new <- b; fn args[d->new] + B -> new' <- c; fn args[d->new'] +-} +caseSplit :: FuncDef -> Expression -> Transform Expression +caseSplit def exp + = case exp of + Case scrut alts :>>= vars :-> e + -> do e' <- hoistToTopLevel def =<< caseSplit def e + alts' <- forM alts $ \(cond :> branch) -> do newVars <- mapM newVariableFrom vars + e'' <- renameExp (Map.fromList $ zip vars newVars) e' + return $ cond :> (branch :>>= newVars :-> e'') + caseSplit def $ Case scrut alts' + Case scrut alts + -> do alts' <- forM alts $ \(cond :> branch) -> if isCheap branch then return (cond :> branch) + else do branch' <- hoistToTopLevel def =<< caseSplit def branch + return (cond :> branch') + return $ Case scrut alts' + _other + -> tmapM (caseSplit def) exp + +isCheap exp = expressionSize exp < 5 + +expressionSize exp + = case exp of + Application{} -> 1 + Constant{} -> 1 + Store{} -> 1 + Unit{} -> 1 + StoreHole{} -> 1 + Case _ alts -> sum [ expressionSize branch | cond :> branch <- alts ] + Fetch{} -> 1 + a :>>= _ :-> e-> expressionSize a + expressionSize e + + + +---------------------------- +-- Inlining. + +data Usage + = Once + | Many + | Bottom +joinUsage Bottom _ = Bottom +joinUsage _ Bottom = Bottom +joinUsage Many _ = Many +joinUsage _ Many = Many +joinUsage _ _ = Many + +type FunctionUsage = Map.Map Renamed Usage + +gatherFunctionUsage :: Grin -> FunctionUsage +gatherFunctionUsage grin = Map.unionsWith joinUsage (map functionUsage (grinFunctions grin)) + +functionUsage :: FuncDef -> FunctionUsage +--functionUsage FuncDef{funcDefName = name, funcDefBody = body} +-- | body == unreachable = Map.singleton name Bottom +functionUsage def + = if self `Map.member` usage + then Map.insertWith joinUsage self Many usage + else usage + where usage = expressionUsage (funcDefBody def) + self = funcDefName def + +expressionUsage :: Expression -> FunctionUsage +expressionUsage exp + = case exp of + Application fn _args -> Map.singleton fn Once + Constant{} -> Map.empty + Store{} -> Map.empty + Unit{} -> Map.empty + StoreHole{} -> Map.empty + Case _ alts -> Map.unionsWith joinUsage [ expressionUsage branch | _ :> branch <- alts ] + Fetch{} -> Map.empty + a :>>= _ :-> b -> Map.unionWith joinUsage (expressionUsage a) (expressionUsage b) + +inlinePass :: Grin -> Grin +inlinePass grin + = runTrans (runReaderT (transformExp' inlineWorker) (gatherFunctionUsage grin, functionBodies)) grin + where functionBodies = Map.fromList [ (funcDefName def, (funcDefArgs def, funcDefBody def)) | def <- grinFunctions grin ] + +type Inline a = ReaderT (FunctionUsage, Map.Map Renamed ([Renamed],Expression)) Transform a + +inlineWorker :: FuncDef -> Expression -> Inline Expression +inlineWorker def exp + = do usage <- lookupFunctionUsage (funcDefName def) + case usage of + Many -> inlineWorker' exp + _other -> return exp + where lookupFunctionUsage name = asks (Map.findWithDefault Many name . fst) + +inlineWorker' :: Expression -> Inline Expression +inlineWorker' exp + = case exp of + Application fn args + -> do usage <- lookupFunctionUsage fn + case usage of + Many -> return $ Application fn args + _once -> do mbBody <- functionBody fn + case mbBody of + Nothing -> return $ Application fn args + Just (oldArgs, body) -> ignore fn $ inlineWorker' =<< (lift $ renameExp (Map.fromList $ zip oldArgs args) body) + _other + -> tmapM inlineWorker' exp + where lookupFunctionUsage name = asks (Map.findWithDefault Many name . fst) + ignore fn = local (\(usage,bodies) -> (Map.delete fn usage, bodies)) + functionBody name = asks (Map.lookup name . snd) + + + +---------------------------- +-- Remove unnecessary cases. +-- This removes information from the system. + +caseLowering :: Expression -> Transform Expression +caseLowering exp + = case exp of + Case scrut [cond :> branch] + -> caseLowering branch + Case scrut alts + -> tmapM caseLowering (Case scrut $ removeUnreachableBranches alts) + _other + -> tmapM caseLowering exp + + +unreachable = Application (Builtin "unreachable") [] +removeUnreachableBranches alts = [ cond :> branch | cond :> branch <- alts, branch /= unreachable ] + +promoteBottoms :: Expression -> Expression +promoteBottoms exp + = case tmap promoteBottoms exp of + a :>>= binds :-> b + | b == unreachable || a == unreachable + -> unreachable + other -> other + + +type StoreFetch = ReaderT (Map.Map Expression Expression) Transform + +storeFetch :: Expression -> StoreFetch Expression +storeFetch exp + = case exp of + a :>>= vars :-> e + -> do mbMatch <- asks (Map.lookup a) + case mbMatch of + Nothing -> addBinding a (Unit vars) $ + do let extra = case a of + Store vals -> addBindings [ (Fetch n (head vars), Unit [val]) | (n,val) <- zip [0..] vals ] + _ -> id + e' <- extra $ storeFetch e + return $ a :>>= vars :-> e' + Just new -> storeFetch (new :>>= vars :-> e) + _ -> do mbMatch <- asks (Map.lookup exp) + case mbMatch of + Nothing -> tmapM storeFetch exp + Just new -> return new + where addBinding key val = local (Map.insert key val) + addBindings [] = id + addBindings ((k,v):xs) = addBinding k v . addBindings xs + +----------------------- +-- Simple rewrite rules + +data RewriteRule = RewriteRule Int Value [Renamed] Expression +type RewriteRules = Map.Map Renamed [RewriteRule] + +findRewriteRules :: Grin -> RewriteRules +findRewriteRules grin = Map.fromList (map findRewriteRule (grinFunctions grin)) + +findRewriteRule :: FuncDef -> (Renamed, [RewriteRule]) +findRewriteRule def + = (funcDefName def, worker 0 (funcDefBody def) ) + where worker size exp | size > 5 + = [] + worker size exp + = case exp of + Case scrut alts + | Just idx <- argumentIndex scrut + -> [RewriteRule idx cond (funcDefArgs def) (funcDefBody def) | cond :> branch <- alts ] + a :>>= _ :-> b -> worker (size + expressionSize a) b + _other -> [] + argumentIndex arg = lookup arg (zip (funcDefArgs def) [0..]) + + + + +applyRewriteRules :: Grin -> Grin +applyRewriteRules grin = runTrans (runReaderT (transformExp apply) (scope,rules)) grin + where rules = findRewriteRules grin + scope = Map.empty + +type Scope = Map.Map Renamed Value +type Apply a = ReaderT (Scope, RewriteRules) Transform a + +apply :: Expression -> Apply Expression +apply exp + = case exp of + (Constant val :>>= [bind] :-> exp) + -> addBinding bind val $ + do exp' <- apply exp + return $ Constant val :>>= [bind] :-> exp' + (Unit vals :>>= binds :-> exp) + -> extendBindings (zip vals binds) $ + do exp' <- apply exp + return $ Unit vals :>>= binds :-> exp' + Application fn args + -> do rules <- getRewriteRules fn + let worker [] = return $ Application fn args + worker (RewriteRule idx matchValue fnArgs newExp : rest) + = do mbValue <- isConstant (args!!idx) + case mbValue of + Nothing -> worker rest + Just value + -> if value == matchValue + then lift $ renameExp (Map.fromList $ zip fnArgs args) newExp + else worker rest + worker rules + Case scrut alts + -> do alts' <- forM alts $ \(cond :> branch) -> do branch' <- addBinding scrut cond $ apply branch + return (cond :> branch') + return $ Case scrut alts' + _other + -> tmapM apply exp + +addBinding :: Renamed -> Value -> Apply a -> Apply a +addBinding bind val + = local (\(scope, rules) -> (Map.insert bind val scope, rules)) + +isConstant :: Renamed -> Apply (Maybe Value) +isConstant name + = asks (Map.lookup name . fst) + +extendBinding :: Renamed -> Renamed -> Apply a -> Apply a +extendBinding old new fn + = do mbValue <- isConstant old + case mbValue of + Nothing -> fn + Just val -> addBinding new val fn + +extendBindings :: [(Renamed, Renamed)] -> Apply a -> Apply a +extendBindings [] = id +extendBindings ((a,b):xs) = extendBinding a b . extendBindings xs + +getRewriteRules :: Renamed -> Apply [RewriteRule] +getRewriteRules name + = asks (Map.findWithDefault [] name . snd) + + diff --git a/src/Grin/Stage2/Optimize/Simple.hs b/src/Grin/Stage2/Optimize/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Optimize/Simple.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, NoMonomorphismRestriction #-} +module Grin.Stage2.Optimize.Simple + ( optimize + ) where + +import Grin.Stage2.Types + +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.Map as Map + +import Traverse + +type Opt a = Reader Subst a +type Subst = Map.Map Renamed Renamed + + +optimize :: Grin -> Grin +optimize = grinTrivialCaseCase . grinSimple + +grinSimple :: Grin -> Grin +grinSimple grin + = grin{ grinFunctions = map simpleFuncDef (grinFunctions grin)} + + +simpleFuncDef :: FuncDef -> FuncDef +simpleFuncDef def + = def{ funcDefBody = runKnownCase $ + runConstantPropagation $ + runSimpleExpression (funcDefBody def) } + +runSimpleExpression :: Expression -> Expression +runSimpleExpression e = runReader (simpleExpression e) Map.empty + +simpleExpression :: Expression -> Opt Expression +simpleExpression (Case scrut [cond :> branch] :>>= binds :-> e) + = simpleExpression (Case scrut [cond :> branch :>>= binds :-> e]) +simpleExpression (Unit v1 :>>= v2 :-> b) + = do v1' <- doSubsts v1 + subst (zip v2 (v1' ++ repeat (Builtin "undefined"))) (simpleExpression b) +simpleExpression (e :>>= binds :-> Unit binds') | binds == binds' + = simpleExpression e +simpleExpression (Constant c :>>= (bind:binds) :-> e) + = do e' <- simpleExpression (Unit [] :>>= binds :-> e) + return (Constant c :>>= [bind] :-> e') +simpleExpression (a :>>= v1 :-> Unit v2) | v1 == v2 + = simpleExpression a +simpleExpression ((a :>>= b :-> c) :>>= d) + = simpleExpression (a :>>= b :-> c :>>= d) +simpleExpression (a :>>= b :-> c) + = do a' <- simpleExpression a + c' <- simpleExpression c + return (a' :>>= b :-> c') +simpleExpression (Application fn values) + = liftM (Application fn) $ doSubsts values +simpleExpression (StoreHole size) + = return $ StoreHole size +simpleExpression (Store vs) + = liftM Store $ mapM doSubst vs +simpleExpression (Unit values) + = liftM Unit (mapM doSubst values) +simpleExpression (Case var [Empty :> alt]) + = simpleExpression alt +simpleExpression (Case var []) + = return $ unreachable +simpleExpression (Case val alts) + = do val' <- doSubst val + alts' <- mapM simpleAlt alts + return $ Case val' alts' +simpleExpression (Fetch n p) + = liftM (Fetch n) (doSubst p) +simpleExpression (Constant c) + = return $ Constant c + +unreachable = Application (Builtin "unreachable") [] + +type CP a = Reader (Map.Map Value Renamed) a + +runConstantPropagation :: Expression -> Expression +runConstantPropagation e = runReader (constantPropagation e) Map.empty + +constantPropagation :: Expression -> CP Expression +constantPropagation (Case scrut alts) + = liftM (Case scrut) $ forM alts $ \(cond :> branch) -> do branch' <- local (Map.insert cond scrut) (constantPropagation branch) + return (cond :> branch') +constantPropagation (Constant v) + = do mbVar <- asks $ Map.lookup v + return $ case mbVar of Nothing -> Constant v + Just var -> Unit [var] +constantPropagation e + = tmapM constantPropagation e + + +type KC a = Reader (Map.Map Renamed Value) a + +runKnownCase :: Expression -> Expression +runKnownCase e = runReader (knownCase e) Map.empty + +knownCase :: Expression -> KC Expression +knownCase (Case scrut alts) + = do mbVal <- asks $ Map.lookup scrut + case mbVal of + Nothing -> liftM (Case scrut) $ forM alts $ \(cond :> branch) -> do branch' <- local (Map.insert scrut cond) (knownCase branch) + return (cond :> branch') + Just Empty -> tmapM knownCase (Case scrut alts) + Just val -> case lookup val [ (cond,branch) | cond :> branch <- alts ] of + Nothing -> if any isDefault alts + then tmapM knownCase (Case scrut alts) + else return unreachable + Just branch -> tmapM knownCase branch +knownCase e@(Constant v :>>= (bind:_) :-> _) + = local (Map.insert bind v) + (tmapM knownCase e) +knownCase e + = tmapM knownCase e + + +simpleAlt :: Alt -> Opt Alt +simpleAlt (v :> e) = do e' <- simpleExpression e + return (v :> e') + + +doSubst var + = asks $ \m -> case Map.lookup var m of + Nothing -> var + Just newVar -> newVar + +--doSubsts :: [Renamed] -> Opt [Renamed] +doSubsts = mapM doSubst + +--subst :: [(Renamed, Renamed)] -> Opt a -> Opt a +subst pairs = local $ \m -> Map.fromList pairs `Map.union` m + + + + + + +type M a = ReaderT Subst (State Int) a + +grinTrivialCaseCase :: Grin -> Grin +grinTrivialCaseCase grin + = case runState (runReaderT action Map.empty) (grinUnique grin) of + (grin, newUnique) -> grin{grinUnique = newUnique} + where action = do defs <- mapM trivialCaseFuncDef (grinFunctions grin) + return grin{grinFunctions = defs} + +trivialCaseFuncDef :: FuncDef -> M FuncDef +trivialCaseFuncDef def + = do body <- trivialCaseCase (funcDefBody def) + return def{ funcDefBody = body } + + +isTrivialExpression :: Expression -> Bool +isTrivialExpression Unit{} = True +isTrivialExpression Application{} = True +isTrivialExpression _ = False + +{- + [n] <- case a of + A -> ... + B -> ... + C -> ... + [i] <- case a of + A -> ... + B -> ... + C -> ... +=====> + [n,i] <- case a of + A -> ... + B -> ... + C -> ... +-} +trivialCaseCase :: Expression -> M Expression +trivialCaseCase (Case scrut1 alts1 :>>= binds1 :-> Case scrut2 alts2 :>>= binds2 :-> e) + | scrut1 == scrut2 && all (not.isDefault) alts1 && all (not.isDefault) alts2 + = do alts <- mapM (joinAlt binds1 binds2 alts2) alts1 + trivialCaseCase (Case scrut1 alts :>>= (binds1++binds2) :-> e) +trivialCaseCase (Case scrut1 alts1 :>>= binds1 :-> Case scrut2 alts2) + | scrut1 == scrut2 && all (not.isDefault) alts1 && all (not.isDefault) alts2 + = do alts <- mapM (joinAltEnd binds1 alts2) alts1 + trivialCaseCase (Case scrut1 alts) +trivialCaseCase (Case scrut alts :>>= binds :-> e) | isTrivialExpression e + = do alts' <- forM alts $ \(cond :> branch) -> do binds' <- replicateM (length binds) newVariable + e' <- subst (zip binds binds') (renameExp e) + return (cond :> (branch :>>= binds' :-> e')) + trivialCaseCase (Case scrut alts') +trivialCaseCase (Application fn values) + = liftM (Application fn) $ doSubsts values +trivialCaseCase (StoreHole size) + = return $ StoreHole size +trivialCaseCase (Store vs) + = liftM Store $ mapM doSubst vs +trivialCaseCase (Unit values) + = liftM Unit (mapM doSubst values) +trivialCaseCase (Case val alts) + = do val' <- doSubst val + alts' <- mapM trivialCaseAlt alts + return $ Case val' alts' +trivialCaseCase (Fetch n p) + = liftM (Fetch n) (doSubst p) +trivialCaseCase (Constant c) + = return $ Constant c +trivialCaseCase (e1 :>>= binds :-> e2) + = do e1' <- trivialCaseCase e1 + e2' <- trivialCaseCase e2 + return $ e1' :>>= binds :-> e2' + +trivialCaseAlt :: Alt -> M Alt +trivialCaseAlt (v :> e) = do e' <- trivialCaseCase e + return (v :> e') + + +renameExp :: Expression -> M Expression +renameExp (Application fn values) + = liftM (Application fn) $ doSubsts values +renameExp (StoreHole size) + = return $ StoreHole size +renameExp (Store vs) + = liftM Store $ mapM doSubst vs +renameExp (Unit values) + = liftM Unit (mapM doSubst values) +renameExp (Case val alts) + = do val' <- doSubst val + alts' <- mapM renameAlt alts + return $ Case val' alts' +renameExp (Fetch n p) + = liftM (Fetch n) (doSubst p) +renameExp (Constant c) + = return $ Constant c +renameExp (e1 :>>= binds :-> e2) + = do e1' <- trivialCaseCase e1 + binds' <- replicateM (length binds) newVariable + e2' <- subst (zip binds binds') (trivialCaseCase e2) + return $ e1' :>>= binds' :-> e2' + + +renameAlt :: Alt -> M Alt +renameAlt (v :> e) = do e' <- renameExp e + return (v :> e') + +{- +A -> m a +=====> +A -> do [n] <- m a + [i] <- m b + unit [n,i] +-} +joinAlt binds1 binds2 branches (cond :> branch) + = do binds1' <- replicateM (length binds1) newVariable + binds2' <- replicateM (length binds2) newVariable + let newBranch = findBranch branches + exp' <- subst (zip binds1 binds1') (renameExp newBranch) + return (cond :> (branch :>>= binds1' :-> exp' :>>= binds2' :-> Unit (binds1'++binds2'))) + where findBranch [] = unreachable + findBranch ((c :> branch):xs) | c == cond = branch + | otherwise = findBranch xs + +joinAltEnd binds1 branches (cond :> branch) + = do binds1' <- replicateM (length binds1) newVariable + let newBranch = findBranch branches + exp' <- subst (zip binds1 binds1') (renameExp newBranch) + return (cond :> (branch :>>= binds1' :-> exp')) + where findBranch [] = unreachable + findBranch ((c :> branch):xs) | c == cond = branch + | otherwise = findBranch xs + +isDefault (Empty :> _) = True +isDefault x = False + +newVariable :: M Renamed +newVariable + = do uid <- newUnique + return $ Anonymous uid + +newUnique :: M Int +newUnique + = do uid <- get + put (uid+1) + return uid + diff --git a/src/Grin/Stage2/Pretty.hs b/src/Grin/Stage2/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Pretty.hs @@ -0,0 +1,98 @@ +-- TODO: Use unicode for the symbols. +module Grin.Stage2.Pretty + ( ppGrin + , ppExpression + , ppRenamed + , ppNodeType + ) where + +import CompactString +import Grin.Stage2.Types + +import Text.PrettyPrint.ANSI.Leijen + +import qualified Data.Map as Map + +instance Pretty Grin where + pretty = ppGrin + +ppGrin :: Grin -> Doc +ppGrin grin + = dullblue (text "Nodes:") <$$> + vsep (map (ppNodeDef) (grinNodes grin)) <$$> + dullblue (text "CAFs:") <$$> + vsep (map (ppCAF) (grinCAFs grin)) <$$> + dullblue (text "Functions:") <$$> + vsep (map (ppFuncDef) (grinFunctions grin)) + +ppNodeDef :: NodeDef -> Doc +ppNodeDef (NodeDef name nodeType args) + = text "node" <+> ppNodeType nodeType 0 name <+> hsep (map ppType args) + +ppType PtrType = blue (text "*") +ppType WordType = white (text "#") +ppType NodeType = white (text "!") + +ppNodeType nt n name + = green (worker nt n name) + where worker ConstructorNode 0 name = char 'C' <> ppRenamed name + worker ConstructorNode n name = char 'P' <> int n <> ppRenamed name + worker FunctionNode 0 name = char 'F' <> ppRenamed name + worker FunctionNode n name = char 'P' <> int n <> ppRenamed name + +ppRenamed (Aliased n var) = pretty var <> char '_' <> pretty n +ppRenamed (Anonymous n) = char 'x' <> pretty n +ppRenamed (Builtin p) = char '@' <> pretty p +ppRenamed (External e tys) = parens (text "foreign" <+> text e) -- FIXME: Show types. + +ppCAF :: CAF -> Doc +ppCAF (CAF name value) + = ppRenamed name <+> equals <+> ppValue value + +ppFuncDef :: FuncDef -> Doc +ppFuncDef (FuncDef name returns args body) + = hsep (brackets (int returns) <+> ppRenamed name : map (ppRenamed) args) <+> equals <$$> + indent 2 (ppBeginExpression body) + +ppBeginExpression :: Expression -> Doc +ppBeginExpression e@(_ :>>= _) + = hang 3 (text "do" <+> ppExpression e) +ppBeginExpression e = ppExpression e + +ppExpression :: Expression -> Doc +ppExpression (Unit values) = blue (text "unit") <+> ppValues values +ppExpression (Constant value) = blue (text "constant") <+> ppValue value +ppExpression (Case value alts) + = blue (text "case") <+> ppRenamed value <+> blue (text "of") <$$> + indent 2 (vsep (map (ppAlt) alts)) +ppExpression (Application fn args) + = hsep (ppRenamed fn:map (ppRenamed) args) +ppExpression (Store v) + = blue (text "store") <+> ppValues v +ppExpression (StoreHole n) + = blue (text "store") <+> hsep (replicate n (text "_")) +ppExpression (Fetch n p) + = blue (text "fetch") <> brackets (int n) <+> ppRenamed p +ppExpression (a :>>= [] :-> c) + = ppExpression a <$$> + ppExpression c +ppExpression (a :>>= b :-> c) + = ppValues b <+> text "<-" <+> hang 0 (ppBeginExpression a) <$$> + ppExpression c + +ppAlt (value :> exp) = ppValue value <$$> + indent 2 (text "->" <+> align (ppBeginExpression exp)) + +ppValues vals + = brackets (hsep $ map (ppRenamed) vals) + +ppValue (Node name nodeType missing) + = (ppNodeType nodeType missing name) +ppValue Hole = text "_" +ppValue Empty = text "()" +ppValue (Lit lit) = ppLit lit + +ppLit (Lint i) = integer i +ppLit (Lrational r) = text (show r) +ppLit (Lchar char) = text (show char) +ppLit (Lstring string) = text (show string) diff --git a/src/Grin/Stage2/Rename.hs b/src/Grin/Stage2/Rename.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Rename.hs @@ -0,0 +1,124 @@ +module Grin.Stage2.Rename + ( rename + ) where + +import Control.Monad.State.Strict +import qualified Data.Map as Map + +import Grin.Stage2.Types + +rename :: Grin -> Grin +rename grin = evalState (renameGrin grin) emptyState + where emptyState = S { stateUnique = 1 + , stateSubst = Map.empty } + + +type M a = State S a +-- The substitution map could just as easily be a reader. +data S = S { stateUnique :: !Int + , stateSubst :: Map.Map Renamed Renamed + } + +renameGrin :: Grin -> M Grin +renameGrin grin + = do mapM_ (bind . nodeName) (grinNodes grin) + mapM_ (bind . cafName) (grinCAFs grin) + forM_ (grinFunctions grin) $ \func -> do bind (funcDefName func) + mapM_ bind (funcDefArgs func) + defs <- mapM renameFuncDef (grinFunctions grin) + nodes <- mapM renameNode (grinNodes grin) + cafs <- mapM renameCAF (grinCAFs grin) + entryPoint <- newName (grinEntryPoint grin) + newUnique <- gets stateUnique + return Grin { grinNodes = nodes + , grinCAFs = cafs + , grinFunctions = defs + , grinEntryPoint = entryPoint + , grinUnique = newUnique } + +renameFuncDef :: FuncDef -> M FuncDef +renameFuncDef def + = do name <- newName (funcDefName def) + args <- mapM newName (funcDefArgs def) + body <- renameExpression (funcDefBody def) + return FuncDef{ funcDefName = name + , funcDefReturns = funcDefReturns def + , funcDefArgs = args + , funcDefBody = body } + +renameExpression :: Expression -> M Expression +renameExpression (e1 :>>= binds :-> e2) + = do e1' <- renameExpression e1 + binds' <- mapM bind binds + e2' <- renameExpression e2 + return (e1' :>>= binds' :-> e2') +renameExpression (Application fn args) + = liftM2 Application (newName fn) (mapM newName args) +renameExpression (Case scrut alts) + = do scrut' <- newName scrut + alts' <- mapM renameAlt alts + return $ Case scrut' alts' +renameExpression (Fetch nth ptr) + = liftM (Fetch nth) (newName ptr) +renameExpression (Store args) + = liftM Store (mapM newName args) +renameExpression (StoreHole size) + = return $ StoreHole size +renameExpression (Unit args) + = liftM Unit (mapM newName args) +renameExpression (Constant val) + = liftM Constant (renameValue val) + +renameAlt :: Alt -> M Alt +renameAlt (cond :> branch) + = do cond' <- renameValue cond + branch' <- renameExpression branch + return (cond' :> branch') + +renameValue :: Value -> M Value +renameValue (Node node nt missing_args) + = do node' <- newName node + return $ Node node' nt missing_args +renameValue value = return value + +renameNode :: NodeDef -> M NodeDef +renameNode node + = do name <- newName (nodeName node) + return node{nodeName = name} + +renameCAF :: CAF -> M CAF +renameCAF caf + = do name <- newName (cafName caf) + value <- renameValue (cafValue caf) + return CAF{ cafName = name + , cafValue = value } + +bind :: Renamed -> M Renamed +bind name | isBuiltin name || isExternal name + = return name +bind name + = do uid <- newUnique + s <- get + when (name `Map.member` stateSubst s) $ error $ "Grin.Stage2.Rename.bind: Duplication of (supposedly) unique identifier: " ++ show name + let newName = genNewName name uid + put s { stateSubst = Map.insert name newName (stateSubst s) } + return newName + +newName :: Renamed -> M Renamed +newName oldName | isBuiltin oldName || isExternal oldName = return oldName +newName oldName@(Aliased (-1) _) = return oldName +newName oldName + = do subst <- gets stateSubst + case Map.lookup oldName subst of + Nothing -> error $ "Grin.Stage2.Rename.newName: Unbound variable: " ++ show oldName + Just new -> return new + +newUnique :: M Int +newUnique = do s <- get + let unique = stateUnique s + put s{stateUnique = unique + 1} + return unique + +genNewName (Aliased _uid name) uid = Aliased uid name +genNewName (Anonymous _uid) uid = Anonymous uid +genNewName other _uid = other diff --git a/src/Grin/Stage2/Transform.hs b/src/Grin/Stage2/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Transform.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} +module Grin.Stage2.Transform + ( Transform + , newVariable + , newVariableFrom + , runTrans + , transformExp + , transformExp' + , renameExp + , hoistToTopLevel + ) where + +import Grin.Stage2.Types +import Traverse + +import Control.Monad.State.Strict +import Control.Monad.Reader +import Control.Applicative +import qualified Data.Map as Map +import qualified Data.Set as Set + +data TState = TState { stateGrin :: !Grin } + +newtype Transform a = Transform { unTransform :: State TState a } + deriving (Monad, MonadState TState) + + +newVariable :: MonadState TState m => m Renamed +newVariable = do st <- get + let grin = stateGrin st + put $! st { stateGrin = grin{ grinUnique = grinUnique grin + 1 } } + return $ Anonymous (grinUnique grin) + +newVariableFrom :: MonadState TState m => Renamed -> m Renamed +newVariableFrom oldName + = liftM (mergeNames oldName) newVariable + where mergeNames (Aliased _ name) (Anonymous uid) = Aliased uid name + mergeNames _oldName newName = newName + +pushFuncDef :: MonadState TState m => FuncDef -> m () +pushFuncDef def + = do st <- get + let grin = stateGrin st + put $! st { stateGrin = grin{ grinFunctions = def : grinFunctions grin } } + +runTrans :: Transform a -> Grin -> Grin +runTrans action grin + = case execState (unTransform action) (TState grin) of + tstate -> stateGrin tstate + +transformExp :: MonadState TState m => (Expression -> m Expression) -> m () +transformExp fn + = transformExp' (const fn) + +transformExp' :: MonadState TState m => (FuncDef -> Expression -> m Expression) -> m () +transformExp' fn + = do funcs <- gets (grinFunctions . stateGrin) + modify $ \(TState grin) -> TState (grin{grinFunctions = []}) + defs <- mapM (transformFunc fn) funcs + modify $ \(TState grin) -> TState (grin{grinFunctions = defs ++ grinFunctions grin }) + + +transformFunc :: MonadState TState m => (FuncDef -> Expression -> m Expression) -> FuncDef -> m FuncDef +transformFunc fn def + = do body <- fn def (funcDefBody def) + return def{funcDefBody = body} + + +-- Hoist an expression to a new top-level function. +-- The returned expression calls the new function. +hoistToTopLevel :: FuncDef -> Expression -> Transform Expression +hoistToTopLevel oldFunction exp + = do newName <- newVariableFrom (funcDefName oldFunction) + cafs <- gets (map cafName . grinCAFs . stateGrin) + let unboundArgs = Set.toList (free `Set.difference` Set.fromList cafs) + args <- mapM newVariableFrom unboundArgs + body <- renameExp (Map.fromList (zip unboundArgs args)) exp + let funcDef = FuncDef { funcDefName = newName + , funcDefArgs = args + , funcDefBody = body + , funcDefReturns = funcDefReturns oldFunction } + pushFuncDef funcDef + return $ Application newName unboundArgs + where free = freeVariables exp + + +freeVariables :: Expression -> Set.Set Renamed +freeVariables = worker + where worker (Case scrut alts) = Set.unions (Set.singleton scrut : map freeAlt alts) + worker (Fetch nth var) = Set.singleton var + worker (Store vals) = Set.fromList vals + worker StoreHole{} = Set.empty + worker (Unit vals) = Set.fromList vals + worker (Application fn args) + = Set.fromList args + worker Constant{} = Set.empty + worker (a :>>= vals :-> b) + = Set.unions [ worker a + , worker b `Set.difference` Set.fromList vals ] + freeAlt (val :> exp) = worker exp + + +type Rename = ReaderT (Map.Map Renamed Renamed) Transform + +renameExp :: Map.Map Renamed Renamed -> Expression -> Transform Expression +renameExp m exp = runReaderT (renameExp' exp) m + +renameExp' :: Expression -> Rename Expression +renameExp' (e1 :>>= binds :-> e2) + = bindArguments binds $ \binds' -> + tmapM renameExp' (e1 :>>= binds' :-> e2) +renameExp' (Case scrut alts) + = do scrut' <- rename scrut + Case scrut' <$> mapM renameAlt alts +renameExp' (Store vs) + = Store <$> mapM rename vs +renameExp' (Fetch nth var) + = Fetch nth <$> rename var +renameExp' (Unit vs) + = Unit <$> mapM rename vs +renameExp' (Application fn args) + = Application fn <$> mapM rename args +renameExp' e@Constant{} + = return e +renameExp' e@StoreHole{} + = return e + + +renameAlt (cond :> branch) + = (cond :>) <$> renameExp' branch + +bindArgument arg fn + = do arg' <- newVariable + local (Map.insert arg arg') $ fn arg' + +bindArguments [] fn = fn [] +bindArguments (x:xs) fn = bindArgument x $ \x' -> bindArguments xs $ \xs' -> fn (x':xs') + +rename :: Renamed -> Rename Renamed +rename val = asks $ Map.findWithDefault val val + diff --git a/src/Grin/Stage2/Types.hs b/src/Grin/Stage2/Types.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Stage2/Types.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE TemplateHaskell #-} +module Grin.Stage2.Types + ( module Grin.Stage2.Types + , module Grin.Types + , module Grin.SimpleCore.Types + ) where + +import qualified Grin.Types as Stage1 +import Grin.Types (Renamed(..),NodeType(..),NodeDef(..),Type(..),uniqueId, alias + ,isBuiltin,isExternal,FFIType(..)) + +import CompactString +import Traverse + +import Grin.SimpleCore.Types (Lit(..)) + +--import Data.Binary +--import Data.DeriveTH +--import Control.Monad (ap) + +data Grin + = Grin { grinNodes :: [NodeDef] + , grinCAFs :: [CAF] + , grinFunctions :: [FuncDef] + , grinEntryPoint :: Renamed + , grinUnique :: Int + } + deriving (Eq,Ord) + +data CAF + = CAF { cafName :: Renamed + , cafValue :: Value + } + deriving (Eq,Ord) + +data FuncDef + = FuncDef { funcDefName :: Renamed + , funcDefReturns :: Int + , funcDefArgs :: [Renamed] + , funcDefBody :: Expression + } + deriving (Eq,Ord) + +data Lambda = [Renamed] :-> Expression + deriving (Eq,Ord) +data Alt = Value :> Expression + deriving (Eq,Ord) + +infixr 1 :-> +infixr 1 :>>= +infixr 1 :> + +data Expression + = Expression :>>= Lambda + | Application { expFunction :: Renamed + , expArgs :: [Renamed] } + | Case { expValue :: Renamed + , expAlts :: [Alt] } + | Fetch Int Renamed + | Store [Renamed] + | StoreHole Int + | Unit [Renamed] + | Constant Value + deriving (Eq,Ord) + +instance Traverse Expression where + tmapM fn exp + = case exp of + e1 :>>= binds :-> e2 + -> do e1' <- fn e1 + e2' <- fn e2 + return (e1' :>>= binds :-> e2') + Application{} + -> return exp + Case scrut alts + -> do alts' <- sequence [ do alt' <- fn alt + return (cond :> alt') + | cond :> alt <- alts] + return $ Case scrut alts' + Fetch{} + -> return exp + Store{} + -> return exp + StoreHole{} + -> return exp + Unit{} + -> return exp + Constant{} + -> return exp + +type Variable = CompactString + +data Value + = Node Renamed NodeType Int + | Lit Lit + | Hole + | Empty + deriving (Show,Eq,Ord) + +{- +$(derive makeBinary ''Value) +$(derive makeBinary ''CAF) +$(derive makeBinary ''FuncDef) +$(derive makeBinary ''Expression) +$(derive makeBinary ''Alt) +$(derive makeBinary ''Lambda) +$(derive makeBinary ''Grin) +-} + diff --git a/src/Grin/Transform.hs b/src/Grin/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Grin/Transform.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} +module Grin.Transform + ( Transform + , newVariable + , newVariableFrom + , runTrans + , transformExp + , renameExp + , hoistToTopLevel + ) where + +import Grin.Types +import Traverse + +import Control.Monad.State.Strict +import Control.Monad.Reader +import Control.Applicative +import qualified Data.Map as Map +import qualified Data.Set as Set + +data TState = TState { stateGrin :: !Grin } + +newtype Transform a = Transform { unTransform :: State TState a } + deriving (Monad, MonadState TState) + + +newVariable :: MonadState TState m => m Renamed +newVariable = do st <- get + let grin = stateGrin st + put $! st { stateGrin = grin{ grinUnique = grinUnique grin + 1 } } + return $ Anonymous (grinUnique grin) + +newVariableFrom :: MonadState TState m => Renamed -> m Renamed +newVariableFrom oldName + = liftM (mergeNames oldName) newVariable + where mergeNames (Aliased _ name) (Anonymous uid) = Aliased uid name + mergeNames _oldName newName = newName + +pushFuncDef :: MonadState TState m => FuncDef -> m () +pushFuncDef def + = do st <- get + let grin = stateGrin st + put $! st { stateGrin = grin{ grinFunctions = def : grinFunctions grin } } + +runTrans :: Transform a -> Grin -> Grin +runTrans action grin + = case execState (unTransform action) (TState grin) of + tstate -> stateGrin tstate + +transformExp :: MonadState TState m => (Expression -> m Expression) -> m () +transformExp fn + = do funcs <- gets (grinFunctions . stateGrin) + modify $ \(TState grin) -> TState (grin{grinFunctions = []}) + defs <- mapM (transformFunc fn) funcs + modify $ \(TState grin) -> TState (grin{grinFunctions = defs ++ grinFunctions grin }) + + +transformFunc :: MonadState TState m => (Expression -> m Expression) -> FuncDef -> m FuncDef +transformFunc fn def + = do body <- fn (funcDefBody def) + return def{funcDefBody = body} + + + +-- Hoist an expression to a new top-level function. +-- The returned expression calls the new function. +hoistToTopLevel :: Renamed -> Expression -> Transform Expression +hoistToTopLevel oldName exp + = do newName <- newVariableFrom oldName + cafs <- gets (map cafName . grinCAFs . stateGrin) + let unboundArgs = Set.toList (free `Set.difference` Set.fromList cafs) + args <- mapM newVariableFrom unboundArgs + body <- renameExp (Map.fromList (zip unboundArgs args)) exp + let funcDef = FuncDef { funcDefName = newName + , funcDefArgs = args + , funcDefBody = body } + pushFuncDef funcDef + return $ Application newName unboundArgs + where free = freeVariables exp + +freeVariables :: Expression -> Set.Set Renamed +freeVariables = worker + where worker (Case scrut alts) = Set.unions (Set.singleton scrut : map freeAlt alts) + worker (Store val) = freeValue val + worker (Update _size ptr val) = Set.fromList [ptr, val] + worker (Unit val) = freeValue val + worker (Application fn args) + = Set.fromList args + worker (a :>>= val :-> b) + = Set.unions [ worker a + , worker b `Set.difference` Set.singleton val ] + worker (a :>> b) + = worker a `Set.union` worker b + freeAlt (val :> exp) = worker exp `Set.difference` freeValue val + freeValue (Node _node _nt _missing args) = Set.fromList args + freeValue (Vector args) = Set.fromList args + freeValue Lit{} = Set.empty + freeValue (Variable v) = Set.singleton v + freeValue Hole{} = Set.empty + freeValue Empty = Set.empty + + +type Rename = ReaderT (Map.Map Renamed Renamed) Transform + +renameExp :: Map.Map Renamed Renamed -> Expression -> Transform Expression +renameExp m exp = runReaderT (renameExp' exp) m + +renameExp' :: Expression -> Rename Expression +renameExp' (e1 :>>= bind :-> e2) + = bindArgument bind $ \bind' -> + tmapM renameExp' (e1 :>>= bind' :-> e2) +renameExp' (e1 :>> e2) + = liftM2 (:>>) (renameExp' e1) (renameExp' e2) +renameExp' (Case scrut alts) + = do scrut' <- rename scrut + Case scrut' <$> mapM renameAlt alts +renameExp' (Store v) + = renameValue Store v +renameExp' (Unit v) + = renameValue Unit v +renameExp' (Application fn args) + = Application fn <$> mapM rename args +renameExp' (Update size ptr val) + = return (Update size) `ap` rename ptr `ap` rename val + +renameAlt (Node tag nt missing args :> branch) + = bindArguments args $ \args' -> + (Node tag nt missing args' :>) <$> renameExp' branch +renameAlt (Vector args :> branch) + = bindArguments args $ \args' -> + (Vector args' :>) <$> renameExp' branch +renameAlt (Variable v :> branch) + = bindArgument v $ \v' -> + (Variable v' :>) <$> renameExp' branch +renameAlt (cond :> branch) + = (cond :>) <$> renameExp' branch + +bindArgument arg fn + = do arg' <- newVariable + local (Map.insert arg arg') $ fn arg' + +bindArguments [] fn = fn [] +bindArguments (x:xs) fn = bindArgument x $ \x' -> bindArguments xs $ \xs' -> fn (x':xs') + +rename :: Renamed -> Rename Renamed +rename val = asks $ Map.findWithDefault val val + +renameValue fn (Variable v) + = renameArgs [v] $ \[v'] -> fn (Variable v') +renameValue fn (Node tag nt missing args) + = renameArgs args $ \args' -> fn (Node tag nt missing args') +renameValue fn (Vector args) + = renameArgs args $ \args' -> fn (Vector args') +renameValue fn v + = return $ fn v + +renameArgs args fn + = do m <- ask + let worker acc [] = return (fn (reverse acc)) + worker acc (x:xs) = case Map.lookup x m of + Nothing -> worker (x:acc) xs + Just n -> worker (n:acc) xs + worker [] args + diff --git a/src/Grin/Types.hs b/src/Grin/Types.hs --- a/src/Grin/Types.hs +++ b/src/Grin/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wwarn #-} module Grin.Types ( module Grin.Types , module Grin.SimpleCore.Types @@ -6,38 +7,46 @@ import CompactString -import Grin.SimpleCore.Types (Lit(..)) +import Grin.SimpleCore.Types (Lit(..), FFIType(..)) import Data.Binary import Data.DeriveTH import Control.Monad (ap) +import Traverse +import qualified HashMap as HT + -- Invariants: -- The nodes referred to by the functions are a subset of the nodes in 'grinNodes'. data Grin - = Grin { grinNodes :: [NodeDef] - , grinCAFs :: [CAF] - , grinFunctions :: [FuncDef] - , grinUnique :: Int + = Grin { grinNodes :: [NodeDef] + , grinCAFs :: [CAF] + , grinFunctions :: [FuncDef] + , grinEntryPoint ::Renamed + , grinUnique :: Int } + deriving (Eq) data CAF = CAF { cafName :: Renamed , cafValue :: Value } + deriving (Eq) data FuncDef = FuncDef { funcDefName :: Renamed , funcDefArgs :: [Renamed] , funcDefBody :: Expression } + deriving (Eq) data NodeDef = NodeDef { nodeName :: Renamed , nodeType :: NodeType , nodeArgs :: [Type] } + deriving (Eq,Ord) {- ConstructorNodes represent data, like: Nil, Cons, Char, etc. @@ -52,10 +61,10 @@ = PtrType | WordType | NodeType - deriving (Eq) + deriving (Eq,Ord) -data Lambda = Renamed :-> Expression -data Alt = Value :> Expression +data Lambda = Renamed :-> Expression deriving (Show, Eq) +data Alt = Value :> Expression deriving (Show, Eq) infixr 1 :-> infixr 1 :>>= @@ -69,17 +78,52 @@ | Case { expValue :: Renamed , expAlts :: [Alt] } | Store Value + | Update Int Renamed Renamed -- size, ptr, value | Unit Value + deriving (Show, Eq) +instance Traverse Expression where + tmapM fn exp + = case exp of + e1 :>>= bind :-> e2 + -> do e1' <- fn e1 + e2' <- fn e2 + return (e1' :>>= bind :-> e2') + e1 :>> e2 + -> do e1' <- fn e1 + e2' <- fn e2 + return (e1' :>> e2') + Application{} + -> return exp + Case scrut alts + -> do alts' <- sequence [ do alt' <- fn alt + return (cond :> alt') + | cond :> alt <- alts] + return $ Case scrut alts' + Store{} + -> return exp + Update{} + -> return exp + Unit{} + -> return exp + + type Variable = CompactString -- FIXME: Writer manual Eq and Ord instances for Renamed. data Renamed = Aliased Int CompactString | Anonymous Int | Builtin CompactString - | External String + | External String [FFIType] deriving (Show,Eq,Ord) +instance HT.Hashable Renamed where + hash (Aliased uid _alias) = uid + hash (Anonymous uid) = uid + hash Builtin{} = 0 + hash External{} = 0 + + isAliased, isBuiltin, isExternal :: Renamed -> Bool isAliased Aliased{} = True @@ -94,6 +138,17 @@ alias :: Renamed -> Maybe CompactString alias (Aliased _ name) = Just name alias _ = Nothing + +numbered :: Renamed -> Bool +numbered Aliased{} = True +numbered Anonymous{} = True +numbered _ = False + +uniqueId :: Renamed -> Int +uniqueId (Aliased uid _name) = uid +uniqueId (Anonymous uid) = uid +uniqueId (Builtin prim) = error $ "Grin.Types.uniqueId: Primitive: " ++ show prim +uniqueId (External fn tys) = error $ "Grin.Types.uniqueId: External: " ++ show fn data Value = Node Renamed NodeType Int [Renamed] diff --git a/src/HashMap.hs b/src/HashMap.hs new file mode 100644 --- /dev/null +++ b/src/HashMap.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module HashMap + ( Hashable(..) + , HashMap + , unpack + , empty + , singleton + , fromList + , toList + , insert + , insertWith + , lookup + , member + , delete + , findWithDefault + ) where + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Data.Maybe +import Prelude hiding (lookup) +import Control.Parallel.Strategies + + +class Ord a => Hashable a where + hash :: a -> Int + hash _ = 0 + +newtype HashMap k v = HashMap (IntMap.IntMap (Map.Map k v)) + deriving (Eq, Ord, NFData) + +instance (Show k, Show v, Hashable k) => Show (HashMap k v) where + showsPrec n = showsPrec n . toMap + +unpack :: HashMap k v -> IntMap.IntMap (Map.Map k v) +unpack (HashMap a) = a + +toMap :: Hashable k => HashMap k v -> Map.Map k v +toMap (HashMap imap) + = Map.unions (IntMap.elems imap) + +empty :: HashMap k v +empty = HashMap IntMap.empty + +singleton :: (Hashable k) => k -> v -> HashMap k v +singleton k v = HashMap (IntMap.singleton (hash k) (Map.singleton k v)) + +fromList :: Hashable k => [(k,v)] -> HashMap k v +fromList lst + = HashMap $ IntMap.fromListWith Map.union [ (hash k, Map.singleton k v) | (k,v) <- lst ] + +toList :: Hashable k => HashMap k v -> [(k,v)] +toList (HashMap imap) = concatMap Map.toList (IntMap.elems imap) +--toList = Map.toList . toMap + +toAscList :: Hashable k => HashMap k v -> [(k,v)] +toAscList = Map.toAscList . toMap + +insert :: Hashable k => k -> v -> HashMap k v -> HashMap k v +insert k v (HashMap imap) + = HashMap $ IntMap.insertWith Map.union (hash k) (Map.singleton k v) imap + +insertWith :: Hashable k => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v +insertWith merge k v (HashMap imap) + = HashMap $ IntMap.insertWith (Map.unionWith merge) (hash k) (Map.singleton k v) imap + +lookup :: Hashable k => k -> HashMap k v -> Maybe v +lookup k (HashMap imap) + = do m <- IntMap.lookup (hash k) imap + Map.lookup k m + +member :: Hashable k => k -> HashMap k v -> Bool +member k (HashMap imap) + = case IntMap.lookup (hash k) imap of + Nothing -> False + Just m -> Map.member k m + +delete :: Hashable k => k -> HashMap k v -> HashMap k v +delete k (HashMap imap) + = HashMap $ IntMap.update fn (hash k) imap + where fn m = let m' = Map.delete k m + in if Map.null m' then Nothing else Just m' + +findWithDefault :: Hashable k => v -> k -> HashMap k v -> v +findWithDefault def k ht + = fromMaybe def (lookup k ht) diff --git a/src/HashSet.hs b/src/HashSet.hs new file mode 100644 --- /dev/null +++ b/src/HashSet.hs @@ -0,0 +1,81 @@ +module HashSet + ( Hashable(..) + , HashSet + , empty + , singleton + , fromList + , toList + , union + , insert + , delete + , member + , difference + , isSubsetOf + , approxSuperset + ) where + +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import Data.Maybe +import Prelude hiding (lookup) + +import HashMap (Hashable(..), HashMap) +import qualified HashMap + +newtype HashSet v = HashSet (IntMap.IntMap (Set.Set v)) + deriving (Eq, Ord) + +instance (Show v, Hashable v) => Show (HashSet v) where + showsPrec n = showsPrec n . toSet + +toSet :: Hashable v => HashSet v -> Set.Set v +toSet (HashSet imap) + = Set.unions (IntMap.elems imap) + +empty :: HashSet v +empty = HashSet IntMap.empty + +singleton :: (Hashable v) => v -> HashSet v +singleton v = HashSet (IntMap.singleton (hash v) (Set.singleton v)) + +fromList :: Hashable v => [v] -> HashSet v +fromList lst + = HashSet $ IntMap.fromListWith Set.union [ (hash v, Set.singleton v) | v <- lst ] + +toList :: Hashable v => HashSet v -> [v] +toList = Set.toList . toSet + +union :: Hashable v => HashSet v -> HashSet v -> HashSet v +union (HashSet a) (HashSet b) = HashSet (IntMap.unionWith (Set.union) a b) + +insert :: Hashable v => v -> HashSet v -> HashSet v +insert v (HashSet imap) + = HashSet $ IntMap.insertWith Set.union (hash v) (Set.singleton v) imap + +delete :: Hashable v => v -> HashSet v -> HashSet v +delete v (HashSet imap) + = HashSet $ IntMap.update fn (hash v) imap + where fn s = let s' = Set.delete v s + in if Set.null s' then Nothing else Just s' + +member :: Hashable v => v -> HashSet v -> Bool +member v (HashSet imap) + = case IntMap.lookup (hash v) imap of + Nothing -> False + Just set -> v `Set.member` set + +difference :: Hashable v => HashSet v -> HashSet v -> HashSet v +difference (HashSet a) (HashSet b) + = HashSet $ IntMap.differenceWith worker a b + where worker a' b' = let d = Set.difference a' b' in + if Set.null d then Nothing else Just d + +isSubsetOf :: Hashable v => HashSet v -> HashSet v -> Bool +isSubsetOf (HashSet a) (HashSet b) + = IntMap.isSubmapOfBy (Set.isSubsetOf) a b + +approxSuperset :: Hashable v => HashSet v -> HashMap v k -> Bool +approxSuperset (HashSet a) b + = let m = HashMap.unpack b + a' = IntMap.difference a m + in IntMap.size a' == IntMap.size a diff --git a/src/LhcMain.hs b/src/LhcMain.hs --- a/src/LhcMain.hs +++ b/src/LhcMain.hs @@ -3,6 +3,8 @@ import System.Directory import System.FilePath import System.Environment +import qualified Data.Version as Version +import Paths_lhc import qualified Data.ByteString.Lazy.Char8 as L import System.IO import System.Exit @@ -10,6 +12,7 @@ import Data.Binary import Data.Maybe import Control.Monad +import Data.Time; import Text.Printf import CompactString import qualified Language.Core as Core @@ -17,23 +20,38 @@ import Grin.FromCore import Grin.Pretty import qualified Grin.SimpleCore.DeadCode as Simple -import qualified Grin.Eval.Compile as Compile import qualified Grin.Optimize.Simple as Simple -import qualified Grin.HtmlAnnotate as Html +import qualified Grin.Optimize.Case as Case +import qualified Grin.DeadCode as DeadCode +import qualified Grin.PreciseDeadCode as DeadCode +import qualified Grin.Optimize.Inline as Inline --import Grin.Rename import qualified Grin.HPT as HPT import qualified Grin.Lowering.Apply as Apply +import qualified Grin.Stage2.FromStage1 as Stage2 +import qualified Grin.Stage2.Pretty as Stage2 +import qualified Grin.Stage2.Optimize.Simple as Stage2.Simple +import qualified Grin.Stage2.Optimize.Case as Stage2.Case +import qualified Grin.Stage2.Backend.LLVM as Backend.LLVM +import qualified Grin.Stage2.Backend.C as Backend.C +import qualified Grin.Stage2.DeadCode as Stage2 +import qualified Grin.Stage2.Rename as Stage2 + +import Manager + +--import Tick + -- TODO: We need proper command line parsing. tryMain :: IO () tryMain = do args <- getArgs case args of ("install":files) -> mapM_ installCoreFile files >> exitWith ExitSuccess - ("build":file:args) -> build Build file args >> exitWith ExitSuccess - ("eval":file:args) -> build Eval file args >> exitWith ExitSuccess - ("compile":file:args) -> build Compile file args >> exitWith ExitSuccess - ("execute":file:args) -> execute file args >> exitWith ExitSuccess + ("compile":files) -> build Compile files >> exitWith ExitSuccess + ("benchmark":files) -> build Benchmark files >> exitWith ExitSuccess + ("llvm":files) -> build LLVM files + ["--numeric-version"] -> putStrLn (Version.showVersion version) >> exitWith ExitSuccess _ -> return () @@ -46,15 +64,16 @@ Left errs -> hPutStrLn stderr "errors: " >> print errs Right mod -> do hPutStrLn stderr " done" dataDir <- getAppUserDataDirectory "lhc" + let packagesDir = dataDir "packages" let smod = coreToSimpleCore mod - createDirectoryIfMissing False (dataDir modulePackage smod) - encodeFile (dataDir modulePackage smod moduleName smod) smod + createDirectoryIfMissing False (packagesDir modulePackage smod) + encodeFile (packagesDir modulePackage smod moduleName smod) smod -data Action = Build | Eval | Compile +data Action = Compile | Benchmark | LLVM -build :: Action -> FilePath -> [String] -> IO () -build action file args - = do mod <- parseCore file +build :: Action -> [FilePath] -> IO () +build action files@(file:_) + = do mods <- mapM parseCore files libs <- loadAllLibraries let primModule = SimpleModule { modulePackage = "ghczmprim" , moduleName = "GHCziPrim" @@ -65,66 +84,76 @@ ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,#)") 5 ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,#)") 6 ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,#)") 7 - ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,#)") 8] + ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,#)") 8 + ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,#)") 9 + ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,#)") 10 + ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,,#)") 11 + ,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,,,#)") 12 + ] + , moduleEnums = [] + , moduleDefs = [] } let allModules = Map.insert (modulePackage primModule, moduleName primModule) primModule $ - Map.insert (modulePackage mod, moduleName mod) mod libs - (tdefs, defs) = Simple.removeDeadCode [("main","Main")] ["main::Main.main"] allModules - grin = coreToGrin tdefs defs - opt = iterate Simple.optimize grin !! 2 - applyLowered = Apply.lower opt - (iterations, hpt) = HPT.analyze applyLowered - evalLowered = HPT.lower hpt applyLowered - opt' = iterate Simple.optimize evalLowered !! 2 - out = opt' - case action of - Build -> print (ppGrin out) - Eval -> Compile.runGrin out "main::Main.main" args >> return () - Compile -> do let target = replaceExtension file "lhc" - outputGrin target "_raw" grin - outputGrin target "_simple" opt - outputGrin target "_apply" applyLowered - outputGrin target "_eval" evalLowered - --outputAnnotation target "_eval.html" Map.empty evalLowered - outputGrin target "" out - --outputAnnotation target ".html" Map.empty out + foldr (\mod -> Map.insert (modulePackage mod, moduleName mod) mod) libs mods + -- libs + (tdefs, enums, defs) = Simple.removeDeadCode [("main","Main")] ["main::Main.main"] allModules + grin = coreToGrin tdefs enums defs + let target = replaceExtension file "lhc" - putStrLn $ "Fixpoint found in " ++ show iterations ++ " iterations." + first_fixpoint <- transformer (replaceExtension file "grin") + [ Step "Optimize" Simple.optimize + , Step "Remove dead code" DeadCode.trimDeadCode + , Step "Inline" Inline.inlinePass ] + grin + let applyLowered = Apply.lower first_fixpoint + hptEnv = HPT.mkEnvironment applyLowered + (iterations, hpt) = HPT.analyze applyLowered + (evalLowered, hpt') = HPT.lower hpt applyLowered + timeIt "Lowering apply primitives" $ outputGrin target "_apply" applyLowered + timeIt "Heap points-to analysis" $ do forM_ iterations $ \_ -> do putStr "."; hFlush stdout + outputGrin target "_eval" evalLowered + putStrLn $ "HPT fixpoint found in " ++ show (length iterations) ++ " iterations." - lhc <- findExecutable "lhc" - L.writeFile target $ L.unlines [ L.pack $ "#!" ++ fromMaybe "/usr/bin/env lhc" lhc ++ " execute" - , encode out ] - perm <- getPermissions target - setPermissions target perm{executable = True} + let stage2_raw = Stage2.convert hpt' evalLowered + second_fixpoint <- transformer (replaceExtension file "grin2") + [ Step "Optimize" Stage2.Simple.optimize + , Step "Remove dead code" Stage2.trimDeadCode + , Step "Case optimize" Stage2.Case.optimize + , Step "Rename" Stage2.rename + , Step "Apply rewrite rules" Stage2.Case.applyRewriteRules + , Step "Inline" (Stage2.trimDeadCode . Stage2.Case.inlinePass) + , Step "Apply rewrite rules" Stage2.Case.applyRewriteRules + , Step "Optimize" (Stage2.Simple.optimize . Stage2.trimDeadCode) + ] + stage2_raw + let stage2_out = second_fixpoint + outputGrin2 target "" stage2_out + + case action of + Benchmark -> timeIt "Compiling C code" $ Backend.C.compileFastCode stage2_out (dropExtension target) + LLVM -> timeIt "Compiling LLVM code" $ Backend.LLVM.compile stage2_out target + Compile -> timeIt "Compiling C code" $ Backend.C.compile stage2_out (dropExtension target) outputGrin file variant grin = do let outputFile = replaceExtension file ("grin"++variant) writeFile outputFile (show $ ppGrin grin) return () -outputAnnotation file variant annotation grin - = do let outputFile = replaceExtension file ("grin"++variant) - writeFile outputFile (Html.annotate annotation grin) - -execute :: FilePath -> [String] -> IO () -execute path args - = do inp <- L.readFile path - let grin = decode (dropHashes inp) - --eval grin "main::Main.main" args - Compile.runGrin grin "main::Main.main" args +outputGrin2 file variant grin + = do let outputFile = replaceExtension file ("grin2"++variant) + writeFile outputFile (show $ Stage2.ppGrin grin) return () - where dropHashes inp | L.pack "#" `L.isPrefixOf` inp = L.unlines (drop 1 (L.lines inp)) - | otherwise = inp - loadAllLibraries :: IO (Map.Map ModuleIdent SimpleModule) loadAllLibraries = do dataDir <- getAppUserDataDirectory "lhc" - packages <- getDirectoryContents dataDir + let packageDir = dataDir "packages" + packages <- getDirectoryContents packageDir smods <- forM (filter (`notElem` [".",".."]) packages) $ \package -> - do modules <- getDirectoryContents (dataDir package) + do modules <- getDirectoryContents (packageDir package) forM (filter (`notElem` [".",".."]) modules) $ \mod -> - do smod <- decodeFile (dataDir package mod) + do -- putStrLn $ "Loading: " ++ (packageDir package mod) + smod <- decodeFile (packageDir package mod) return ((package,mod),smod) return $ Map.fromList [ (ident, mod) | (ident,mod) <- concat smods ] @@ -136,3 +165,15 @@ Left errs -> error (show errs) Right mod -> do --putStrLn $ "parsing done: " ++ path return (coreToSimpleCore mod) + +{- +timeIt :: String -> IO a -> IO a +timeIt msg action + = do printf "%-40s" (msg ++ ": ") + hFlush stdout + s <- getCurrentTime + a <- action + e <- getCurrentTime + printf "%.2fs\n" (realToFrac (diffUTCTime e s) :: Double) + return a +-} diff --git a/src/Manager.hs b/src/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Manager.hs @@ -0,0 +1,59 @@ +module Manager where + +import Text.PrettyPrint.ANSI.Leijen +import Text.Printf +import System.FilePath +import System.IO +import Data.Time + +data Step a = Step String (a -> a) + +type Transformer a = a -> IO a + +transformer :: (Eq a, Pretty a) => FilePath -> [Step a] -> Transformer a +transformer target [] firstValue = return firstValue +transformer target steps firstValue + = worker 0 steps firstValue firstValue + where worker n [] startValue endValue + | startValue == endValue + = do printf "\nFound fixpoint in %d iterations.\n" (n `div` length steps ::Int) + return endValue + | otherwise + = worker n steps endValue endValue + worker n (Step name fn:xs) startValue intermediaryValue + = do let targetFile = printf "%s_%03d" target n + value = fn intermediaryValue + --timeIt name $ writeFile targetFile (show $ pretty value) + writeFile targetFile (show $ pretty value) + putStr "." >> hFlush stdout + worker (n+1) xs startValue value + + + +timeIt :: String -> IO a -> IO a +timeIt msg action + = do printf "%-40s" (msg ++ ": ") + hFlush stdout + s <- getCurrentTime + a <- action + e <- getCurrentTime + printf "%.2fs\n" (realToFrac (diffUTCTime e s) :: Double) + return a + +{- + +let first_loop = transformers "grin" [ step "Optimize" Simple.optimize + , step "Remove dead code" DeadCode.trimDeadCode + , step "Inline" Inline.inlinePass ] + +first_fixpoint <- run step1 grin_from_core +let lowered = evalLowered first_fixpoint + stage2_initial = stage1_to_stage2 first_fixpoint + second_loop = transformers "grin2" [ step "Optimize" Stage2.Simple.optimize + , step "Remove dead code" trimDeadCode + , step "Rename" rename + , step "Rewrite" rewrite + , step "Inline" inline ] +second_fixpoint <- run second_loop stage2_initial + +-} diff --git a/tests/1_io/basic/Args.args b/tests/1_io/basic/Args.args new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/Args.args @@ -0,0 +1,1 @@ +Foo Bar Baz diff --git a/tests/1_io/basic/Args.expected.stdout b/tests/1_io/basic/Args.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/Args.expected.stdout @@ -0,0 +1,3 @@ +Foo +Bar +Baz diff --git a/tests/1_io/basic/Args.hs b/tests/1_io/basic/Args.hs new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/Args.hs @@ -0,0 +1,6 @@ +import System.Environment + +main :: IO () +main = do + as <- getArgs + mapM_ putStrLn as diff --git a/tests/1_io/basic/Echo.expected.stdout b/tests/1_io/basic/Echo.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/Echo.expected.stdout @@ -0,0 +1,6 @@ +MODULE MAIN WHERE + +IMPORT DATA.CHAR + +MAIN :: IO () +MAIN = INTERACT (MAP TOUPPER) diff --git a/tests/1_io/basic/Echo.hs b/tests/1_io/basic/Echo.hs new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/Echo.hs @@ -0,0 +1,6 @@ +module Main where + +import Data.Char + +main :: IO () +main = interact (map toUpper) diff --git a/tests/1_io/basic/Echo.stdin b/tests/1_io/basic/Echo.stdin new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/Echo.stdin @@ -0,0 +1,6 @@ +module Main where + +import Data.Char + +main :: IO () +main = interact (map toUpper) diff --git a/tests/1_io/basic/HelloWorld.expected.stdout b/tests/1_io/basic/HelloWorld.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/HelloWorld.expected.stdout @@ -0,0 +1,1 @@ +Hello, World! diff --git a/tests/1_io/basic/HelloWorld.hs b/tests/1_io/basic/HelloWorld.hs new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/HelloWorld.hs @@ -0,0 +1,4 @@ + + +main :: IO () +main = putStrLn "Hello, World!" diff --git a/tests/1_io/basic/IORef.expected.stdout b/tests/1_io/basic/IORef.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/IORef.expected.stdout @@ -0,0 +1,1 @@ +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx diff --git a/tests/1_io/basic/IORef.hs b/tests/1_io/basic/IORef.hs new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/IORef.hs @@ -0,0 +1,18 @@ + + + +import Data.IORef + +fact :: Int -> IO Int +fact n = do + ref <- newIORef 1 + let f 1 = return () + f n = modifyIORef ref (n*) >> f (n - 1) + f n + readIORef ref + + +main = do + r <- fact 5 + putStrLn (replicate r 'x') + diff --git a/tests/1_io/basic/enum.expected.stdout b/tests/1_io/basic/enum.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/enum.expected.stdout @@ -0,0 +1,15 @@ +(False,True) +(0,1) +(False,True) +Wednesday +[10,9,8,7,6,5,4,3,2,1,0,-1,-2,-3,-4,-5,-6,-7,-8,-9,-10,-11,-12] +[1,5,9,13] +[100,93,86,79,72,65,58,51,44] +(Sunday,Saturday) +[Friday,Thursday,Wednesday,Tuesday,Monday,Sunday] +[Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday] +[Wednesday,Thursday,Friday,Saturday] +[Wednesday,Thursday,Friday,Saturday] +[Friday,Thursday,Wednesday,Tuesday,Monday,Sunday] +[Monday,Tuesday,Wednesday,Thursday,Friday,Saturday] +[Monday,Wednesday,Friday] diff --git a/tests/1_io/basic/enum.hs b/tests/1_io/basic/enum.hs new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/enum.hs @@ -0,0 +1,25 @@ + +import Data.Word + +data Day = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday + deriving(Eq,Ord,Enum,Show,Bounded) + +main :: IO () +main = do + print (False,True) + print (fromEnum False, fromEnum True) + print (toEnum 0 :: Bool, toEnum 1 :: Bool) + print $ (toEnum 3 :: Day) + print [10 :: Int, 9 .. -12 ] + print [1, 5 :: Word8 .. 16 ] + print [100, 93 :: Word8 .. 43 ] + print (minBound :: Day,maxBound :: Day) + print [Friday, Thursday .. ] + print [Sunday .. ] + print [Wednesday .. ] + print [Wednesday .. Saturday] + print [Friday, Thursday .. ] + print [Monday, Tuesday .. ] + print [Monday, Wednesday .. ] + + diff --git a/tests/1_io/basic/fastest_fib.expected.stdout b/tests/1_io/basic/fastest_fib.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/fastest_fib.expected.stdout @@ -0,0 +1,11 @@ +17711 +47 +17711 +17711 +17711 +17711 +47 +17711 +17711 +17711 +17711 diff --git a/tests/1_io/basic/fastest_fib.hs b/tests/1_io/basic/fastest_fib.hs new file mode 100644 --- /dev/null +++ b/tests/1_io/basic/fastest_fib.hs @@ -0,0 +1,30 @@ +import Data.List +import Data.Word +import Data.Int + +fib1 n = snd . foldl fib' (1, 0) . map toEnum $ unfoldl divs n + where + unfoldl f x = case f x of + Nothing -> [] + Just (u, v) -> unfoldl f v ++ [u] + + divs 0 = Nothing + divs k = Just (uncurry (flip (,)) (k `divMod` 2)) + + fib' (f, g) p + | p = (f*(f+2*g), f^(2::Int) + g^(2::Int)) + | otherwise = (f^(2::Int)+g^(2::Int), g*(2*f-g)) + +main :: IO () +main = do + print (fib1 22 :: Int) + print (fib1 22 :: Int8) + print (fib1 22 :: Int16) + print (fib1 22 :: Int32) + print (fib1 22 :: Int64) + print (fib1 22 :: Word) + print (fib1 22 :: Word8) + print (fib1 22 :: Word16) + print (fib1 22 :: Word32) + print (fib1 22 :: Word64) + print (fib1 22 :: Integer) diff --git a/tests/2_language/Bounds.expected.stdout b/tests/2_language/Bounds.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/Bounds.expected.stdout @@ -0,0 +1,8 @@ +-128 +127 +-32768 +32767 +-2147483648 +2147483647 +-9223372036854775808 +9223372036854775807 diff --git a/tests/2_language/Bounds.hs b/tests/2_language/Bounds.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/Bounds.hs @@ -0,0 +1,13 @@ +module Main where + +import Data.Int + +main :: IO () +main = do print (minBound :: Int8) + print (maxBound :: Int8) + print (minBound :: Int16) + print (maxBound :: Int16) + print (minBound :: Int32) + print (maxBound :: Int32) + print (minBound :: Int64) + print (maxBound :: Int64) diff --git a/tests/2_language/CPP.expected.stdout b/tests/2_language/CPP.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/CPP.expected.stdout @@ -0,0 +1,1 @@ +in lhc diff --git a/tests/2_language/CPP.hs b/tests/2_language/CPP.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/CPP.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} + +#ifdef __LHC__ +main = putStrLn "in lhc" +#else +main = putStrLn "not in lhc" +#endif diff --git a/tests/2_language/Defaulting.expected.stdout b/tests/2_language/Defaulting.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/Defaulting.expected.stdout @@ -0,0 +1,2 @@ +4611686018427387904 +3.141592653589793 diff --git a/tests/2_language/Defaulting.hs b/tests/2_language/Defaulting.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/Defaulting.hs @@ -0,0 +1,6 @@ +x = 2^62 +y = pi + +main :: IO () +main = do print x + print y diff --git a/tests/2_language/EnumEnum.expected.stdout b/tests/2_language/EnumEnum.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/EnumEnum.expected.stdout @@ -0,0 +1,1 @@ +[LT,EQ,GT] diff --git a/tests/2_language/EnumEnum.hs b/tests/2_language/EnumEnum.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/EnumEnum.hs @@ -0,0 +1,3 @@ + +main :: IO () +main = print [LT ..] diff --git a/tests/2_language/IntEnum.expected.stdout b/tests/2_language/IntEnum.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/IntEnum.expected.stdout @@ -0,0 +1,1 @@ +[16777215,33554431,50331647,67108863,83886079,100663295,117440511,134217727,150994943,167772159,184549375,201326591,218103807,234881023,251658239,268435455,285212671,301989887,318767103,335544319,352321535,369098751,385875967,402653183,419430399,436207615,452984831,469762047,486539263,503316479,520093695,536870911,553648127,570425343,587202559,603979775,620756991,637534207,654311423,671088639,687865855,704643071,721420287,738197503,754974719,771751935,788529151,805306367,822083583,838860799,855638015,872415231,889192447,905969663,922746879,939524095,956301311,973078527,989855743,1006632959,1023410175,1040187391,1056964607,1073741823,1090519039,1107296255,1124073471,1140850687,1157627903,1174405119,1191182335,1207959551,1224736767,1241513983,1258291199,1275068415,1291845631,1308622847,1325400063,1342177279,1358954495,1375731711,1392508927,1409286143,1426063359,1442840575,1459617791,1476395007,1493172223,1509949439,1526726655,1543503871,1560281087,1577058303,1593835519,1610612735,1627389951,1644167167,1660944383,1677721599,1694498815,1711276031,1728053247,1744830463,1761607679,1778384895,1795162111,1811939327,1828716543,1845493759,1862270975,1879048191,1895825407,1912602623,1929379839,1946157055,1962934271,1979711487,1996488703,2013265919,2030043135,2046820351,2063597567,2080374783,2097151999,2113929215,2130706431,2147483647] diff --git a/tests/2_language/IntEnum.hs b/tests/2_language/IntEnum.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/IntEnum.hs @@ -0,0 +1,3 @@ +import Data.Int +main = do print . take 0x101 $ [0xffffff,0x1ffffff :: Int32 ..] + diff --git a/tests/2_language/IrrefutableLambda.expected.stdout b/tests/2_language/IrrefutableLambda.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/IrrefutableLambda.expected.stdout @@ -0,0 +1,1 @@ +Hi! diff --git a/tests/2_language/IrrefutableLambda.hs b/tests/2_language/IrrefutableLambda.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/IrrefutableLambda.hs @@ -0,0 +1,1 @@ +main = (\ ~(a,b) -> putStrLn "Hi!") undefined diff --git a/tests/2_language/KindInference.expected.stdout b/tests/2_language/KindInference.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/KindInference.expected.stdout diff --git a/tests/2_language/KindInference.hs b/tests/2_language/KindInference.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/KindInference.hs @@ -0,0 +1,12 @@ +class Arrow a where + arr :: (b -> c) -> a b c + (>>>) :: a b c -> a c d -> a b d + +newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } + +instance Monad m => Arrow (Kleisli m) where + arr f = Kleisli (return . f) + Kleisli f >>> Kleisli g = Kleisli (\x -> f x >>= g) + +main :: IO () +main = return () diff --git a/tests/2_language/Kleisli.expected.stdout b/tests/2_language/Kleisli.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/Kleisli.expected.stdout diff --git a/tests/2_language/Kleisli.hs b/tests/2_language/Kleisli.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/Kleisli.hs @@ -0,0 +1,15 @@ +-- demonstrates bug in interaction between multi-parameter newtypes +-- and class instances rules? (Please setup a bug tracker soon! Then I +-- could just refer to the bug number, and not write an unclear/false +-- description of the bug ;-) + +newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } + +class Arrow a where + arr :: (b -> c) -> a b c + +instance Monad m => Arrow (Kleisli m) where + arr f = Kleisli (return . f) + +main :: IO () +main = runKleisli (arr id) () diff --git a/tests/2_language/Laziness.expected.stdout b/tests/2_language/Laziness.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/Laziness.expected.stdout @@ -0,0 +1,1 @@ +() diff --git a/tests/2_language/Laziness.hs b/tests/2_language/Laziness.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/Laziness.hs @@ -0,0 +1,8 @@ +module Main where + +{-# NOINLINE fn #-} +fn :: Int -> ((),Bool) +fn x = ((), case x of 0 -> True; _ -> False) + +main :: IO () +main = print (fst (fn undefined)) diff --git a/tests/2_language/NoMonomorphism.expected.stdout b/tests/2_language/NoMonomorphism.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/NoMonomorphism.expected.stdout @@ -0,0 +1,3 @@ +9 +15.6 +2.8957571600107794e-36 diff --git a/tests/2_language/NoMonomorphism.hs b/tests/2_language/NoMonomorphism.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/NoMonomorphism.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LHC_OPTIONS -fno-monomorphism-restriction #-} + +x = 234 +y = 15 + +main = do print (x `mod` y) + print (x / y) + print (x ** (-y)) + diff --git a/tests/2_language/PureInteger.expected.stdout b/tests/2_language/PureInteger.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/2_language/PureInteger.expected.stdout @@ -0,0 +1,1 @@ +[2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768,65536,131072,262144,524288,1048576,2097152,4194304,8388608,16777216,33554432,67108864,134217728,268435456,536870912,1073741824,2147483648,4294967296,8589934592,17179869184,34359738368,68719476736,137438953472,274877906944,549755813888,1099511627776,2199023255552,4398046511104,8796093022208,17592186044416,35184372088832,70368744177664,140737488355328,281474976710656,562949953421312,1125899906842624,2251799813685248,4503599627370496,9007199254740992,18014398509481984,36028797018963968,72057594037927936,144115188075855872,288230376151711744,576460752303423488,1152921504606846976,2305843009213693952,4611686018427387904,9223372036854775808,18446744073709551616,36893488147419103232,73786976294838206464,147573952589676412928,295147905179352825856,590295810358705651712,1180591620717411303424,2361183241434822606848,4722366482869645213696,9444732965739290427392,18889465931478580854784,37778931862957161709568,75557863725914323419136,151115727451828646838272,302231454903657293676544,604462909807314587353088,1208925819614629174706176,2417851639229258349412352,4835703278458516698824704,9671406556917033397649408,19342813113834066795298816,38685626227668133590597632,77371252455336267181195264,154742504910672534362390528,309485009821345068724781056,618970019642690137449562112,1237940039285380274899124224,2475880078570760549798248448,4951760157141521099596496896,9903520314283042199192993792,19807040628566084398385987584,39614081257132168796771975168,79228162514264337593543950336,158456325028528675187087900672,316912650057057350374175801344,633825300114114700748351602688,1267650600228229401496703205376] diff --git a/tests/2_language/PureInteger.hs b/tests/2_language/PureInteger.hs new file mode 100644 --- /dev/null +++ b/tests/2_language/PureInteger.hs @@ -0,0 +1,2506 @@ +--LICENSE: BSD3 (or also similar, like GHC, etc.) +--INITIAL AUTHOR: Isaac Dupree +-- +-- modified by austin seipp for use with LHC +{- + (search file for INTERESTING to customize) + + What is this? It is a reimplementation, in Haskell, of the + Integer type that Haskell provides in its Prelude. It is designed + in mind of being actually usable as the implementation of that type, + for compilers. It is also a module that exports a working + Integer type. It is in terms of only basic Prelude functions, [], + and Int. It is NOT a purely inductive definition, because Int is + much faster than a purely inductive definition would allow, and + nevertheless often easier to come by (more portable, license-wise, + size-wise, nuisance-wise...) than GMP or other C bignum libraries. + +SPEED: + It is not too slow on small numbers (smallish constant - much + larger than for Int of course), not too slow on medium-size + numbers (which I've been testing it with), and not too slow on + large numbers (asymptotically; karatsuba multiplication, + O(n^1.585) is used to split up large numbers, and division by + large numbers uses multiplication and Newton's method). + Also see BUGS for the speed of 'show'. + +CORRECTNESS: + It seems to be correct, after a fairly thorough million-iteration + QuickCheck in GHC plus a lot of quickcheck testing using + debugging-"Int"s that tell you when they overflow and have + (minBound,maxBound)=(-31,31). Each of these caught an incredible + number of bugs, which is why I am inclined to trust them. + Unfortunately, most Haskell implementations are somewhat incorrect + - see COMPILERS. Also see CAVEATS(c) for *very* large numbers. + +CAVEATS: + a- It is obviously much slower than GMP. (although I don't know if + the penalties for calling primitive/foreign functions + counterbalance that for small numbers.) + b- It assumes that Int operations are fairly fast, although it + doesn't tend to waste them that much (e.g. it uses `quotRem` + when it needs both, which is almost always). + c- It is expected to break when handling values with magnitude + greater than around ( (maxBound::Int)^(maxBound::Int) ). + (just like GMP. Probably the assumption is that you'll run + out of memory at the same time, or that the operations will + take SO LONG, so no-one cares. + Prelude.length will (relatedly) also break at this point.) + +CODE SIZE: + Could be smaller, but then, could be larger too. Possibly + some environments will not appreciate when I have duplicated + functionality in order to make some size of operation go faster. + Of course these could be changed. So far I have refrained from + CPP, but there are probably some ways CPP could be used to make it + easier to customize. The prime / single-quote symbol is + deliberately not used as part of any identifiers, there are no + string gaps or backslashes at end of lines, + // /* */ are treated nicely, so I hope CPP won't mess anything up. + +USAGE AS NATIVE INTEGER: + Completely untried so far (search file for INTERESTING to + customize). + + The algorithms are quite separable from the newtype Integer and + its instances, and Bits, Ix... parts can be separated out too + (in which case a proper export list would have to be made for the + algorithm functions, which might hinder optimization a little, + if assuming separate compilation...). + See + for all things GHC's Prelude.Integer be an instance of, including + Typeable? Data? NFData? PrintfArg? Typeable? Random? + This is also a purpose CPP could be useful for, to define (#define?) + quotRemDInt and such type-specific things, conditionally on how + this Integer-implementation is being used. + + The internal format is (currently) a list([]) of Ints + in base "intLargeBase", least-significant "digit" first + (negative x is represented by negating all elements of + the list that represents positive x) + (No most-significant zeroes are allowed + (so zero is represented by the empty list, for example)) + ("intLargeBase" is customizable, although there is an optimal + value for any particular size of Int, and a limit based on the + Int's size) + +TODO/BUGS: + COMPILERS. + a- There is one WORKAROUND so Hugs can compile it and two for + nhc/yhc. Even so, I refused to keep a third workaround for + N/Yhc, but that is for a nyhc bug that Neil thinks should be + reasonably fixable. + b- though extensively QuickChecked in GHC, Hugs occasionally fails + QuickCheck, but when the particular example is run in Hugs, + it gives the correct answer! I think Hugs is buggy. + (Hugs Version September 2006) + c- ghc -O -fvia-C may miscompile "quotRem x (some power of two)". + (ghc trac#1603) + If QuickCheck fails badly on you, try adding -fasm. + d- Beware testing in interpreters - some (at least GHCi 6.6.1) + will default to Prelude.Integer even if the module has + "default ()". + + Make show faster than O(n^2), e.g. see + http://darcs.haskell.org/packages/base/GHC/Num.lhs ? + ...but converting that, it seemed altogether slower than the + current + `signum (2 P.^ (1000000::P.Int)) :: Integer` works in a few + seconds in ghci + `P.length (show ((2 P.^ (1000000::P.Int)) :: Integer))` + takes much longer, in fact hasn't finished yet + (slower for "reasonable-size" Integers to be shown, I mean, + which were the only ones I tested with) + With -O2 and the "O(n^2)" implementation of show, + `length (show ((2 P.^ (100000::Prelude.Int)) + :: IntegerInTermsOfInt.Integer))` + took my computer about 15 seconds, and + `length (show ((2 P.^ (1000000::Prelude.Int)) + :: IntegerInTermsOfInt.Integer))` + about 5000 seconds. Looks quadratic to me, but what to do + about it? NB. This has a real effect on testing with + LargeBase=16(Int=[-31..31]) + + The multiplication and division code, which is the most + complicated, is not documented well enough. (N.B. refactoring + and renaming are often part of documenting) (This is somewhat + improved now, but it's still not very organized...) + + Bits, of course, requires a power-of-two base... and assumes two's + complement Int; however, it does not need ((-maxBound)-1 ::Int) + to be a possible value, because of how the digits are + represented. + Also the Bits code has not been cleaned up at all. + + Maybe `par` stuff could be inserted... (division is the slowest, + not sure quite why it's so bad, but it might be worth examining + (except 'show' on incredibly large inputs, of course)) (Remember + to test with -threaded; apparently that allows `par` to use + CPU-level parallelism; do you have to give an RTS option to tell + it your number of CPUs too?) + + try using data LD = LDNil | LDCons {-#UNPACK#-}!DInt !LD as rep + and see how GHC performs + names?: :+* low :+* highs for low + base * highs + + addition.. is still O(max) as long as mkInteger traverses the + whole thing. Since I use the strict constructor ((!:) currently) + everywhere, this is not necessary, only for assertions + (also careful of Prelude.{map,splitAt} producing non-strict lists) + + CONVERSION code uses literal 0 as overloaded + +-} +module Main where +--cleaned of \t , [ \t]$ , .\{80,\} , +-- \(let\|where\|do\|of\)[ ] such that the layout following them extends +--onto another line , +--ghc -Wall #except a warning when not using intBaseGuesses (Bounded Int) +-- -fno-warn-unused-binds #for now +-- -fno-warn-incomplete-patterns #ghc's incomplete pattern checker +-- #isn't very strong. While I haven't been able to get Catch +-- #to tell me anything useful, QuickCheck passes. +-- #Should I just make all my patterns artificially complete? +--Also avoiding "'"s in identifiers, for cpp's sake , +--syntactic sugar that is likely not to work pre-Prelude as well as +--in case the list type wants to be replaced... + +import Prelude ( + --all the Int operations are only portably available from typeclasses + --(also, Integer has to be made an instance of most of these classes) + Eq(..), Ord(..), Num(..), Enum(..), Integral(..), Show(..), Real(..), + --[](..), --lists are built-in syntax + Bool(..), Ordering(..), + seq, -- we need to use seq on the Ints, + -- to make (seq (someInteger)) work as expected + -- some things are just too convenient: + (&&), (||)--, not + , id, const + ) + +--WORKAROUND (for Hugs and NYhc) +--For hugs to import (:) (and 2-tuples? other list bits?) we have to import +--Prelude unqualified, and not like import Prelude () +-- -- conformant implementations like GHC will not even +--accept explicit imports of those things. +--Also a June 19 2007 YHC from darcs seems quite broken without this import. +--But we don't want to import anything but [](..), ()(..), (,)(..), +-- (,,)(..) and so on +--so we hide everything that according to Haskell98 would be importable. +import Prelude hiding + --manually copied down everything from :browse Prelude in ghci + ((++),error,foldr,seq,concat,filter,zip,print,fst,snd,otherwise,(&&),(||) + ,Bounded(..),Enum(..),Eq(..),Floating(..),Fractional(..),Integral(..) + ,Monad(..),Functor(..),Num(..),Ord(..),Read(..),Real(..),RealFloat(..) + ,RealFrac(..),Show(..),Bool(..),Char,Double,Float,Int + ,Integer,Ordering(..),Rational,IO,Either(..) + ,putChar,putStr,putStrLn,getChar,getLine,getContents,interact,readFile + ,writeFile,appendFile,readLn,readIO,($!),String,map,not,id,const,(.),flip,($) + ,until,asTypeOf,IOError,FilePath,ioError,userError,ReadS,catch,unwords + ,unlines,words,lines,minimum,maximum,product,sum,foldl1,either,lex,read + ,readParen,reads,ShowS,showParen,showString,showChar,shows,subtract + ,realToFrac,fromIntegral,(^^),(^),lcm,gcd,odd,even,unzip3,unzip,zipWith3 + ,zipWith,zip3,lookup,notElem,elem,break,span,dropWhile,takeWhile,splitAt + ,drop,take,cycle,replicate,repeat,iterate,scanr1,scanr,scanl1,scanl,concatMap + ,all,any,or,and,foldr1,foldl,reverse,(!!),length,null,init,tail,last,head + ,undefined,uncurry,curry,maybe,(=<<),sequence_,sequence,mapM_,mapM,Maybe(..)) + +-- useful list stuff: (some list functions use a hardcoded Int type...) +import qualified Prelude as L ((++), map, last, Int + , take, reverse, drop, length, splitAt, foldr1 + , all) +-- other ghastly debug stuff, currently only (++) and (show) in an assertion +-- that could be deleted though: +import qualified Prelude as P +import Prelude as Print (print) +--import qualified Prelude as BaseOp (numerical...) +--import qualified Prelude as LengthOp (numerical...) +--literals? negative literals? + +--INTERESTING +import qualified Prelude as D (Int) +--import qualified TestingInt as D (Int) +-- -- ^ assert(we are not being the native integer) +-- because TestingInt is implemented in terms of it. + + + +-- **** for guessing the base *** +import Prelude (minBound, maxBound) + +-- *** for conversions with Num/Integral? *** +-- use this to convert from an arbitrary integral - it might be optimized, +-- and it's as good as (fromInteger . toInteger) +import qualified Prelude as Misc (fromIntegral) +-- SPECIALIZE for this type +import qualified Prelude as N (Integer, Int) + +-- ****** instances, newtype imports ******** + +--for defining Integer instances +import qualified Prelude as Class ( + Eq(..),Ord(..),Num(..),Enum(..),Integral(..),Show(..),Real(..),Read(..) ) +import qualified {-"Data." optional of course-}Data.Ix as Class ( Ix(..) ) +--import qualified Random as Class ( Random(..) ) +--Copy Random instance from System.Random where it's normally defined, +--if you want. +--Same for Typeable? Data? NFData? PrintfArg? +import {-qualified-} Data.Bits as Class ( Bits(..) ) + +--used for Show Integer auxiliary functions' type signatures +import Prelude (String) + +--for defining Read Integer +import Numeric (readSigned, readDec) + +--for defining Integral Integer (quotRem) +import Prelude as Error (error) + +--INTERESTING probably the second definition (or deleting all asserts) +-- is better for some purposes... +--import TestingDebug +assert :: Show e => e -> Bool -> a -> a +assert _ True x = x +assert err False _ = error (show err) +--assert :: b -> c -> a -> a; assert _ _ a = a + +--WORKAROUND +--true, but breaks nhc/yhc currently: +--default () + + + +--could be cpp macros... and each usage defined explicitly +--e.g. listLit0, listLit1, listLitNeg1 +--listLIT +--listLITNeg +--intLIT +--lenLIT +--integralLIT(Neg) +--D(.)Int: a digit, as in our lists of ints. +--PInt: length/list/prelude Int +--HInteger: the integer we're defining here +--NInteger: the native integer +--HInteger__: HInteger, just not constructor-boxed nor necessarily deep-seq'd +--dIntNeg1 --may be a macro +--only [DInt] and [[DInt]] are actually used, never in a way that actually +--has to be polymorphic! And we never use value-level [x] sugar. +--Now we just need to change type-signatures a bit +--(and allow prelude list functions to be replaced) +--and we can use (L for list, D for digit) +--data LD = LDNil | LDCons {-#UNPACK#-}(?)!DInt !(?)LD +--or similar, and also define LLD or: type LLD = [] LD +--Some places may still rely on the laziness of lists though +--(those should be fixed, for easier experimenting) +type PInt = L.Int +type DInt = D.Int +-- PInt +-- TestingInt.Int +type HInteger__ = [DInt] + +type IdF t = t -> t --or "Endo"... +-- "nat" = natural = nonnegative; "neg" = negative +-- these must be used as if they could be functions OR macros, +-- i.e. generally "(xNeg(1))" if it is to be usable wherever "3" is. +-- (numeric literals in patterns are avoided anyway.) +dNat, dNeg :: IdF DInt; dNat x = x; dNeg = negate +pNat{-, pNeg-} :: IdF PInt; pNat x = x--; pNeg = negate +-- if (nonnegative) numeric literals are already working, these should work: +-- #define dNat(x) ((x) :: DInt) +-- #define dNeg(x) (negate (x) :: DInt) +-- #define pNat(x) ((x) :: PInt) +---- #define pNeg(x) (negate (x) :: PInt) +-- If integer literals won't do at all,(assuming DInt==PInt - easy to change) +-- #define dNat(x) (nat/**/x) +-- #define dNeg(x) (neg/**/x) +-- #define pNat(x) (nat/**/x) +---- #define pNeg(x) (neg/**/x) +-- (is /**/ the right concatenation syntax there? should it be ##? ...) +-- and define nat0, nat1, neg1, nat2 ... (whatever ones are used) +-- somehow. + +infixr 5 !: +(!:) :: DInt -> [DInt] -> [DInt] +d !: ds = d `seq` ds `seq` (d : ds) +strictMap :: (DInt -> DInt) -> [DInt] -> [DInt] +strictMap f = m + where + m (d:ds) = f d !: m ds + m [] = [] + +--S = signed, LE = little-endian +--Large = within the largeIntBase (or at least base that, for the LELists); +--similarly for Small... +--Large is the default when neither is mentioned in a name. +type LargeSInt = DInt +type LargeBaseLEList = [LargeSInt] +type SmallSInt = DInt +type SmallBaseLEList = [SmallSInt] + +validBase :: DInt -> [DInt] -> Bool +validBase _base [] = True +validBase base ds@(_:_) = + let sign = signum (L.last ds) + in ((dNat(1)) == sign || (dNeg(1)) == sign) + && L.all (\digit -> + negate base < digit && digit < base && + (sign * digit) >= (dNat(0))) ds + +--Prefer if/then/else to guards with otherwise, so an interpreter +--doesn't have to evaluate "otherwise" + +--let's collect all literals here for easy reference/hackability +--(for different implementations possibly) +--(also to try to make sure interpreters don't duplicate work...) +--zero, one, two, negativeOne, +intLargeBase, intSmallBase :: DInt +intLargeExponentOfTwo, intSmallExponentOfTwo :: PInt +--zero = 0; one = 1; two = 2; negativeOne = -1 + +{-plusOne, minusOne, twice,-} +twicePlusOne :: DInt -> DInt +{-plusOne n = succ n --succ n or 1+n +minusOne n = pred n --pred n or n - 1 or (-1)+n +twice n = n + n --two*n or n+n ... -} +twicePlusOne n = succ (n + n) --or plusOne (twice n) + +--INTERESTING +--must be true: +-- * intSmallBase^2 = intLargeBase +-- * (intLargeBase-1)*2+1 <= (maxBound::DInt) +-- * negate ( (intLargeBase-1)*2+1 ) >= (minBound::DInt) +--if the ExponentOfTwos are ever USED by the code, these need to be true +--as well: +-- * 2^intLargeExponentOfTwo = intLargeBase +-- * 2^intSmallExponentOfTwo = intSmallBase +(intLargeBase, intLargeExponentOfTwo, intSmallBase, intSmallExponentOfTwo) + = {-sees "ibg"-} intBaseGuesses --whatever powers of 2 are best +-- = (268435456, 28, 16384, 14) --Haskell98 minimum (30 or 31 bit, signed) +-- = (1073741824, 30, 32768, 15) --32-bit (signed) +-- = (4611686018427387904, 62, 2147483648, 31) --64-bit (signed) +-- = (1000000, nonsense, 1000, nonsense) where nonsense = nonsense + + +--Originally I had intLargeBase=2^28, intSmallBase=2^14 +--to stay within Haskell98 (-2^29,2^29). + +--if we don't consider class Bits or hypothetical machine speed, +--there is no good reason we should require anything other than +-- intLargeBase == intSmallBase^2 | (base - 1)*2 + 1 <= maxBound +--But either way the minimum is DInt [-7..7] (large [-3..3], small [-1..1]) +--and we don't lose that much by rounding down to only the power-of-two bases. +--(although, base large=100/small=10 might help people understand/debug it, +--though it is already permissible to _imagine_ that -- and it would +--make read/show quite efficient...) + +--A search is tricky since we have to stay within unknown capabilities +--(we don't have Integer yet, it _depends_ on these results!) +--Also since it is not _required_ that minBound is not a great deal larger +--in magnitude than maxBound, for example, we need to be careful about that. + +--It is rather recommended to have SmallBase > 10 (for Show) +-- ==> LargeBase > 100 ==> a range of at least +-199; +-- which rules out single-byte; +-- and powers of two are also recommended; leaving a reasonable minimum +-- at SmallBase=16; LargeBase=256; range at least +- (2^9 - 1): +-- 16-bit Ints should work just fine (although larger sizes are still +-- preferable of course, as long as they have fast arithmetic +-- including quotRem :) + +intBaseGuesses :: (DInt,PInt,DInt,PInt) +intBaseGuesses + = assert ( + --This may happen if someone tries an unsigned, e.g. Word... + "IntegerInTermsOfInt: (Signed) range of DInt (way) too small:\n" P.++ + "[" P.++P.show minDInt P.++ ".." P.++P.show maxDInt P.++ "]::DInt" P.++ + "; [-31..31]::needed." --or [-17..17] if we allow/guess non-powers-of-2 + ) ( + (minDInt < (dNat(0)) && maxDInt > (dNat(0)) + && minDInt < (dNat(1)) && maxDInt > (dNat(1)) + && smallExponentResult > (pNat(1)) --for division - was >0=[-7..7] + ) + ) result + where + result@(_,_,_,smallExponentResult) = f (dNat(0)) (pNat(0)) + (dNat(0)) (pNat(0)) + minDInt, maxDInt :: DInt + minDInt = minBound; maxDInt = maxBound + --if the remainder has a magnitude of 1 rather than 0, the modulus + --may be one more than half the bound rounded down + --(there's then room for a carry of 1 in n+n) + -- iff <, safe to double (>=, can't double); if <=, safe to use/accept. + maxLargeBase = case maxDInt `quotRem` (dNat(2)) of (q,r) -> q + r + minNegLargeBase = case minDInt `quotRem` (dNat(2)) of (q,r) -> q + r + safeToDoublePlusOne n = n < maxLargeBase && minNegLargeBase < negate n +-- --safeToDouble implies safeToUse +-- safeToDouble n = n < maxLargeBase && minNegLargeBase < negate n +-- safeToUse n = n <= maxLargeBase && minNegLargeBase <= negate n + -- f takes arguments known to be in-bounds for valid use + -- (i.e., safeToDoublePlusOne) and returns the largest that work. + f nLarge nLargeExponentOfTwo nSmall nSmallExponentOfTwo = + let + twoNLarge = twicePlusOne nLarge; fourNLarge = twicePlusOne twoNLarge + in {-traces "f" traces nLarge traces twoNLarge P.$ -} + if safeToDoublePlusOne twoNLarge && safeToDoublePlusOne fourNLarge + then f (fourNLarge) (nLargeExponentOfTwo + (pNat(2))) + (twicePlusOne nSmall) (nSmallExponentOfTwo + (pNat(1))) + else ( (succ nLarge), (nLargeExponentOfTwo) + , (succ nSmall), (nSmallExponentOfTwo) ) + +--no overflow allowed to be possible when calling these: +quotRemByIntLargeBase, quotRemByIntSmallBase :: DInt -> (DInt, DInt) +--the OrZero is needed for dealing with carries (a.k.a. borrows)... +-- preconditions: +{-addIntLargeBaseToMakePositiveOrZero -- negate intLargeBase <= input < 0 + , addIntSmallBaseToMakePositiveOrZero -- as above but with intSmallBase + , subtractIntLargeBaseToMakeNegativeOrZero -- 0 < input <= intLargeBase + , subtractIntSmallBaseToMakeNegativeOrZero -- as above but with intSmallBase + , complementInt + , multiplyByIntSmallBase + :: DInt -> DInt +-} +--might implement via Bits (they all can be, assuming a two's complement DInt) +--(although it seems divMod is more natural than quotRem +--to implement via Bits) +quotRemByIntLargeBase input = input `quotRem` intLargeBase +quotRemByIntSmallBase input = input `quotRem` intSmallBase +{---adding and subtracting are lightning-fast machine instructions, we don't +--need alternatives! +addIntLargeBaseToMakePositiveOrZero input = input + intLargeBase +addIntSmallBaseToMakePositiveOrZero input = input + intSmallBase +--these don't like the OrZero for Bits... +subtractIntLargeBaseToMakeNegativeOrZero input = input - intLargeBase +subtractIntSmallBaseToMakeNegativeOrZero input = input - intSmallBase +complementInt input = minusOne (negate input) +multiplyByIntSmallBase input = input * intSmallBase +-} + +--inverse of quotRemByIntSmallBase +--perhaps should be named unQuotRemByIntSmallBase? be uncurried? +highLowFromIntSmallBase :: DInt->DInt -> DInt +highLowFromIntSmallBase high low = high * intSmallBase + low + +-- [-intLargeBase, intLargeBase) -intLargeBase becomes 0 +repairNegIntLargeBase :: DInt -> DInt +repairNegIntLargeBase d = d `rem` intLargeBase + +isZero{-, isPositive, isNegative-} :: DInt -> Bool +isZero = ((dNat(0)) ==) +--isNegative = ((dNat(0)) >) +--isPositive = ((dNat(0)) <) + +--could use bit-shifts: and addition and comparison are, I think, the +--only other operations PInt needs. Maybe even could use Double???? +--I'm not sure if PInt ever even needs to be negative. +pTwice :: PInt -> PInt +pTwice x = x + x +-- may not use on negative numbers: +pHalfRoundingDown, pHalfRoundingUp :: PInt -> PInt +pHalfRoundingDown x = x `quot` 2 +pHalfRoundingUp x = pHalfRoundingDown (succ x) + + + + + +-- *********************** SIGN, and COMPARISON ********************** + +--requires the two to each have consistent signs throughout +--little-endian all-same-sign no-most-significant-zero required +--Works with any one base. +compareInteger :: HInteger__ -> HInteger__ -> Ordering +--Either we can go looking for integer1 and integer2 having opposite +--signs early, avoiding zero digits, +--or we can not bother (which will often be faster due to simplicity). +compareInteger (d1:ds1) (d2:ds2) = + case compareInteger ds1 ds2 of + EQ -> compare d1 d2 + answer -> answer +compareInteger ds1@(_:_) [] = compareNonzeroIntegerZero ds1 +compareInteger [] ds2@(_:_) = compareZeroNonzeroInteger ds2 +compareInteger [] [] = EQ + +--requires the two to each have consistent signs throughout +--little-endian all-same-sign no-most-significant-zero required +--Works with any one base. +compareAbsInteger :: HInteger__ -> HInteger__ -> Ordering +compareAbsInteger (d1:ds1) (d2:ds2) = + case compareAbsInteger ds1 ds2 of + EQ -> compare (abs d1) (abs d2) + answer -> answer +compareAbsInteger (_:_) [] = GT +compareAbsInteger [] (_:_) = LT +compareAbsInteger [] [] = EQ + + +zeroInteger, oneInteger, negativeOneInteger :: HInteger__ +zeroInteger = [] +oneInteger = (dNat(1)) !: [] +negativeOneInteger = (dNeg(1)) !: [] + +isZeroInteger :: HInteger__ -> Bool +isZeroInteger [] = True +isZeroInteger (_:_) = False + +--these can only return GT and LT ... +--A case for [] would be enough to remove the "nonzero" restriction! But then +--the postcondition would not be automatically checked (it might return EQ +--somewhere that would act oddly if it received EQ). +compareNonzeroIntegerZero, compareZeroNonzeroInteger :: HInteger__ -> Ordering +compareNonzeroIntegerZero = + \(d:ds) -> case compare d (dNat(0)) of + EQ -> compareNonzeroIntegerZero ds + answer -> answer +compareZeroNonzeroInteger = + \(d:ds) -> case compare (dNat(0)) d of + EQ -> compareZeroNonzeroInteger ds + answer -> answer + +compareIntegerZero :: HInteger__ -> Ordering +compareIntegerZero [] = EQ +compareIntegerZero integer@(_:_) = compareNonzeroIntegerZero integer + +isNegativeInteger :: HInteger__ -> Bool +isNegativeInteger i = compareIntegerZero i == LT + +signumInteger :: HInteger__ -> HInteger__ +signumInteger a = case compareIntegerZero a of + { GT -> oneInteger; LT -> negativeOneInteger; EQ -> zeroInteger } + +-- they work on just about anything... maybe not absInteger on +-- mixed-sign lists. +negateInteger, absInteger :: [DInt] -> [DInt] +negateInteger = strictMap negate +absInteger = strictMap abs + + + + + +--or could judge 0 as positive, or,,,: +signNonzeroInteger :: HInteger__ -> DInt +signNonzeroInteger (d:ds) = let s = signum d in + if isZero s then signNonzeroInteger ds else s + + +-- ******************* ADDITION / SUBTRACTION ************************* + +-- PUTTING TOGETHER VALID INTEGER BITS: +-- prepend is like (:)/cons except it won't add a most-significant zero. +prepend :: DInt -> [DInt] -> [DInt] +prepend d [] | isZero d = [] +prepend d ds = d !: ds +prependZero :: [DInt] -> [DInt] +prependZero [] = [] +prependZero ds = (dNat(0)) !: ds +prependNonzero :: DInt -> [DInt] -> [DInt] +prependNonzero d ds = d !: ds +--it doesn't check, as it doesn't even know what the intended base is, +--but it should not be used on an overflowing DInt: +fromDInt :: DInt -> [DInt] +fromDInt d = if isZero d then [] else d !: [] + +-- For us, adding numbers with opposite signs is much the same as +-- subtracting numbers with the same sign ("destructive"), +-- and adding-same is similar to subtracting opposites ("synergistic"), +-- but the two are rather different from each other. +-- (and adding zero is trivial.) +-- average O(min(m,n)), worst-case O(max(m,n))=O(m+n) +addInteger :: HInteger__ -> HInteger__ -> HInteger__ +addInteger [] integer = integer +addInteger integer [] = integer +addInteger integer1 integer2 = + if compareNonzeroIntegerZero integer1 == compareNonzeroIntegerZero integer2 + then synergisticAdd integer1 integer2 + else destructiveAdd intLargeBase integer1 integer2 + + +-- Positive plus positive or negative plus negative, +-- no most-significant zeroes in arguments nor results. +-- (zero works fine as either(?)) +--carrying can only be by +-1 at most +synergisticAdd :: LargeBaseLEList -> LargeBaseLEList -> LargeBaseLEList +synergisticAdd integer1 integer2 = + synergisticAddWithCarry integer1 integer2 (dNat(0)) + +synergisticAddWithCarry :: LargeBaseLEList -> LargeBaseLEList -> DInt + -> LargeBaseLEList +synergisticAddWithCarry (d1:ds1) (d2:ds2) carry = + case quotRemByIntLargeBase (d1 + d2 + carry) of + (carry_, d_) -> d_ !: synergisticAddWithCarry ds1 ds2 carry_ +synergisticAddWithCarry [] [] carry = fromDInt carry +synergisticAddWithCarry ds@(_:_) [] carry = synergisticAddOnlyCarry ds carry +synergisticAddWithCarry [] ds@(_:_) carry = synergisticAddOnlyCarry ds carry + +-- like adding. carry is zero or +-one. (or maybe it can be >1) +synergisticAddOnlyCarry :: LargeBaseLEList -> DInt -> LargeBaseLEList +synergisticAddOnlyCarry integer carry = + if isZero carry --then optimize even if integer is nonzero + then integer + else case integer of + [] -> carry !: [] + (d:ds) -> case quotRemByIntLargeBase (d + carry) of + (carry_, d_) -> d_ !: synergisticAddOnlyCarry ds carry_ +synergisticAddOnlyCarrySmall :: SmallBaseLEList -> DInt -> SmallBaseLEList +synergisticAddOnlyCarrySmall integer carry = + if isZero carry + then integer + else case integer of + [] -> carry !: [] + (d:ds) -> case quotRemByIntSmallBase (d + carry) of + (carry_, d_) -> d_ !: synergisticAddOnlyCarrySmall ds carry_ + +destructive + :: (DInt -> DInt -> DInt) -> {-base:: -}DInt + -> HInteger__{-base-} + -> HInteger__{-base-} -> HInteger__{-base-} +--destructive _ _ [] [] = [] --not needed, with non-strictness... +destructive op base integer1 integer2 + = destructive_ op base (signNonzeroInteger integer1) integer1 integer2 + +--Now works on (<=0)-(<=0)=(<=0) if told to: +--{-pass negative base-}, and change compare i1 i2 to +--compare (abs i1) (abs i2) (= comparing abs i1 i2 = on compare abs i1 i2) +--, and succ->(+sign), oneInteger->sign:[],base->sign*base +--to allow subtracting negatives just as well +--Now with abs, should be easy addDestructive too. or destructive (+)... +destructive_ + :: (DInt -> DInt -> DInt) -> {-base:: -}DInt + -> DInt -> HInteger__{-base-} + -> HInteger__{-base-} -> HInteger__{-base-} +destructive_ (+- {-either (+) or (-)-} ) base sign = sub + where + --s=signed + sBase = sign * base +-- sInteger = sign !: [] +-- sPlusOne = (+)sign--(`minus` (negate 1))--sign)) + sub [] [] = [] + sub ds@(_:_) [] = ds +--sub [] ds@(_:_) = disallowed + sub (d1:ds1) (d2:ds2) = case compare (abs d1) (abs d2) of +--Avoids sending any DInt to the opposite sign even temporarily + GT -> prependNonzero (( d1) +- d2) (sub ds1 ds2) + EQ -> prependZero (sub ds1 ds2) + LT -> prependNonzero ((sBase + d1) +- d2) (subBorrow ds1 ds2) +-- LT -> prepend ((sBase + d1) - d2) (sub ds1 (inc ds2)) + --borrowing: may produce d2=base: + --(which yields the only reason the LT case isn't prependNonzero) +-- inc [] = sInteger +-- inc (i2raw:ds2) = (sPlusOne i2raw) !: ds2 +--subBorrow [] _ = disallowed + subBorrow (d1:ds1) (d2:ds2) = case compare (abs d1) (succ (abs d2)) of + GT -> prependNonzero ((( d1) +- d2) - sign) (sub ds1 ds2) + EQ -> prependZero (sub ds1 ds2) + LT -> prepend (((sBase + d1) +- d2) - sign) (subBorrow ds1 ds2) + subBorrow ds1@(_:_) [] = borrow ds1 + borrow (d1:ds1) = if isZero d1 + then prependNonzero ( sBase{- + 0 +- 0-} - sign) (borrow ds1) --LT 1 + else prepend ( d1{-+- 0-} - sign) (ds1) --EQ/GT 1 +{-- +--One argument should be all-nonpositive, the other all-nonnegative. +--Result can only have most-significant zeroes if an argument does. +--Arguments/result may be in any base. +destructiveAddProducingMixedSign :: [DInt] -> [DInt] + -> [DInt] +destructiveAddProducingMixedSign (d1:ds1) (d2:ds2) = + prepend (d1 + d2) (destructiveAddProducingMixedSign ds1 ds2) +destructiveAddProducingMixedSign ds@(_:_) [] = ds +destructiveAddProducingMixedSign [] ds@(_:_) = ds +destructiveAddProducingMixedSign [] [] = [] +--} +destructiveAdd :: {-base:: -}DInt -> HInteger__{-base-} -> HInteger__{-base-} + -> HInteger__{-base-} +destructiveAdd base integer1 integer2 = + case compareAbsInteger integer1 integer2 of + GT -> destructive (+) base integer1 integer2 + LT -> destructive (+) base integer2 integer1 + EQ -> zeroInteger +--} +{- +destructiveAdd base integer1 integer2 = + assert ("destructiveAdd: good arguments",integer1,integer2) ( + validBase base integer1 && validBase base integer2 && + (isZeroInteger integer1 || isZeroInteger integer2 || + compareNonzeroIntegerZero integer1 /= compareNonzeroIntegerZero integer2)) + P.$ + (\a -> assert ("destructiveAdd: good result",a,(integer1,integer2)) + (validBase base a) a) P.$ + makeSignConsistent base (destructiveAddProducingMixedSign integer1 integer2) +--} +{-- +--uh oh, this separation is meaning that the whole result will be traversed, +--time-wasting. er, in fact, having to find the sign does risk that, for +--"round" numbers at least - but same for deciding syn. vs. destr., and +--adding/subtracting a little near there always risks O(n) +--integer must have no most-significant zeroes (so we can find its sign) +--and the most-significant digit (or being the null list) +--is the ONLY sure indicator of its sign. +makeSignConsistent :: {-base:: -}DInt -> [DInt] -> HInteger__{-base-} +makeSignConsistent base integer = makeSign_ integer + where + --addBaseToFlipSign starts with a nonzero, and MAY produce zero + --If we have a special case for integer=0, then the other branch + --(not so recursive) would clearly be strict in this: ... + (compareToDesiredSign, addBaseToFlipSign, carryReducingOne) = + case compare (L.last integer) (dNat(0)) of + GT -> (\x -> compare x (dNat(0)), \x -> x + base, \x -> pred x) + LT -> (\x -> compare (dNat(0)) x, \x -> x - base, \x -> succ x) + makeSign_ :: [DInt] -> [DInt] + makeSign_ [] = [] + makeSign_ (d:ds) = + case compareToDesiredSign d of + GT{-already correct sign-} -> prependNonzero d (makeSign_ ds) + LT{-wrong sign (but abs value IS within base)-} -> + -- +Base in d's place == -1 in ds's place + prepend + (addBaseToFlipSign d) -- +Base in d's place... + (case ds of + --If the sign ds inconsistent, making the + -- sign consistent won't increase the magnitude + -- of the number, as it can only conflict with itself. + --So "ds" must be non-null here. + -- -- ... == -1 in ds's place + (d_:ds_) -> makeSign_ (carryReducingOne d_ !: ds_) + ) + EQ{-zero-} -> prependZero (makeSign_ ds) +--} + +-- ************************* MULTIPLICATION *************************** + +-- Multiplication (and division...) need smaller bases of list +-- in order not to lose any precision on DInt-multiplies (and +-- not rely on any particular overflow behavior either). + +-- never allows a most-significant zero in result +-- assuming the argument had none +largeToSmallBaseLEList :: LargeBaseLEList -> SmallBaseLEList +largeToSmallBaseLEList [] = [] +largeToSmallBaseLEList (d:ds) = + case quotRemByIntSmallBase d of + (high,low) -> low !: prepend high (largeToSmallBaseLEList ds) + --if the argument had no most-significant zero, then, processing + --its most-significant digit, at least one of high and low will be + --nonzero. + +smallToLargeBaseLEList :: SmallBaseLEList -> LargeBaseLEList +smallToLargeBaseLEList [] = [] +smallToLargeBaseLEList (low:high:ds) = (highLowFromIntSmallBase high low) + !: smallToLargeBaseLEList ds +smallToLargeBaseLEList (low:[]) = low !: [] + + +-- ************* Naive O(m*n) multiplication. *********** +-- It is the simplest and most efficient when either factor is small. + +--we need DInt multiply not to overflow (that wastes information) +--so we split the Ints up, turning it into a signed base sqrt(intLargeBase) + + +--no *0! also see other preconditions of naiveMultiplyIntegerSmall_ +naiveMultiplyInteger_ :: HInteger__ -> HInteger__ -> HInteger__ +naiveMultiplyInteger_ i1{-@(_:_)-} i2{-@(_:_)-} = + smallToLargeBaseLEList + (naiveMultiplyIntegerSmall_ + (largeToSmallBaseLEList i1) + (largeToSmallBaseLEList i2)) +--naiveMultiplyInteger_ _ _ = [] --multiplying by zero yields zero + +type Overflow = [DInt] +--[Overflow] is a list in smallBase whose members are: +-- lists of all the dInts that have to be summed to represent the value at +-- that radix-place; each dInt may be as large as (smallBase - 1) ^ 2 + + +mulBySmall :: DInt{- SmallBaseLEList -> SmallBaseLEList +mulBySmall factor = f (dNat(0)) + where + f carry [] = fromDInt carry + f carry (d:ds) = case quotRemByIntSmallBase (factor * d + carry) of + (high,low) -> low !: f high ds + +-- this requires max list length around smallBase - much too small, +-- (2^32)^(2^17) = 2^4194304, or 10^100000, +-- shouldn't go wacko being squared on a 32bit machine. +-- However, this is significantly faster... +-- WAIT A MOMENT will the karatsuba reduce the huge ones instead? +-- at (2^32)^10 +-- so unless we have (2^32)^5 * (2^32)^(2^17)... +--FALSE: and it's no problem, since the arguments are biased, as long as +-- we put the short one first +-- and karatsuba has their lengths, it knows how to do that +--However, then it will be symmetrically biased (1 2 3 3 3 ... 3 3 2 1) +-- and each sublist will be just the length of the shorter factor, max. +-- Add in the top of a quotRem and it adds ONE to that length, no more. +-- +{-they're not worth it HERE for division's time to be wasted? + - depends on what is common in division - but I think `div` ( low !: fromDInt high +naiveMultiplyIntegerSmall_ i1 (d2:[]) = mulBySmall d2 i1 +naiveMultiplyIntegerSmall_ (d1:[]) i2 = mulBySmall d1 i2 +-} +--precondition: +-- internally, always (sum overflow < largeBase) +-- As each overflow is < smallBase and largeBase/smallBase=smallBase, +-- this means in worst-case of each being smallBase-1, there can be +-- smallBase+1 of them (x-1)(x+1) = x^2-1 = largeBase-1 . +-- One (1) of the overflow can be carry from the previous. +-- Otherwise the maximum length from multiplyToOverflowing is +-- min m n + 1, where m and n are the factors' lengths. mulBySmall +-- can only overflow once, as (x-1)(x-1) + (x-1) = (x)(x-1) < x^2 . +-- So +-- (min m n + 1) + 1 <= smallBase + 1 +-- min m n + 1 <= smallBase +-- min m n < smallBase, +-- as a conservative precondition. +-- Actually... it's slightly more generous than that. The +-- overflow-lengths always trail off at the end like ..3 2 1 [end] +-- (at least, the last list is at least one) +-- and this way our carry is at max, (smallBase-1)*2 (+1?) +-- so in the middle of overflows +-- we have (x-1)(2(x+1)) = 2(x^2-1) = 2x^2-2 < 2x^2 +-- 2(x+1) = (min m n + 1) + 2 +-- min m n + 1 + 2 <= 2*(smallBase+1) +-- min m n + 1 + 2 <= 2*smallBase + 2 +-- min m n + 1 <= 2*smallBase +-- min m n < 2*smallBase +-- . Judging potential factors in largeBase, m and n are half as much as in +-- smallBase: +-- min (2M) (2N) < 2*smallBase +-- 2*(min M N) < 2*smallBase +-- min M N < smallBase +-- But min M N <= smallBase, tested even with smallBase=4 and +-- error-on-overflow, works fine as a condition. Also with smallBase=8. +-- Maybe it has something to do with the fact that in any base b, +-- (b-1)(b-1) = (b^1)(b-2) + (b^0)(something) = b^2 - 2b + something +-- (b-1)(b-1) = b^2 - 2b + 1 so something = 1 +-- This is in mulBySmall. +-- (now examples in smallBase=10) +-- 9 * 999 +-- 1 carry 8 (9*9 = 81) +-- 9 carry 8 (9*9 + 8 = 89) +-- 9 carry 8 ... +-- hmm. +-- Here is a sample of 'high's with smallBase=4 in effect: +-- (from ./CheckIntegerInTermsOfInt 50 2>&1 |grep '^-\?[0-9]\+$'|sort|uniq -c +-- with (traces high) inserted) +-- count 'high'-value +-- ------ + --------- +-- 1210402 0 +-- 555992 1 +-- 166442 -1 +-- 192299 2 +-- 62072 -2 +-- 50194 3 +-- 19838 -3 +-- 10141 4 +-- 4664 -4 +-- 1621 5 +-- 1149 -5 +-- 344 6 +-- 257 -6 +-- 73 7 +-- 43 -7 +--I think negatives are less common because the reciprocal algorithm uses +-- numbers that will always multiply to a positive, in some part of it. +-- Generally the frequency seems to be exponentially unlikely in the value, +-- limited of course by the maximum. +-- Here is a sample trace with smallBase=4 from ghci (formatted for clarity) +-- > naiveMultiplyIntegerSmall_ [3,3,3,3] [3,3,3,3] +-- "overflows" +-- (("sees","overflows"),[[1],[3,1],[3,3,1],[3,3,3,1],[2,3,3,3],[2,3,3] +-- ,[2,3],[2]]) +-- [1,0,0,0,2,3,3,3] +--Although that is not automatically the most dastardly layout of large +--digits, +-- > naiveMultiplyIntegerSmall_ [3,3] [3,3] +-- "overflows" +-- (("sees","overflows"),[[1],[3,1],[2,3],[2]]) +-- [1,0,2,3] +-- > naiveMultiplyIntegerSmall_ [3,3,3] [3,3,3] +-- "overflows" +-- (("sees","overflows"),[[1],[3,1],[3,3,1],[2,3,3],[2,3],[2]]) +-- [1,0,0,2,3,3] +--I seem to have overestimated by one the max number of, and the symmetry of +--overflows? +-- > naiveMultiplyIntegerSmall_ [3,3] [3,3,3] +-- "overflows" +-- (("sees","overflows"),[[1],[3,1],[3,3],[2,3],[2]]) +-- [1,0,3,2,3] +-- > naiveMultiplyIntegerSmall_ [3,3,3] [3,3] +-- "overflows" +-- (("sees","overflows"),[[1],[3,1],[2,3,1],[2,3],[2]]) +-- [1,0,3,2,3] +--Each pack sums to the same thing... in those examples anyway. Of course I +--know from quickcheck that the _answer_ is always right... +-- > naiveMultiplyIntegerSmall_ [3,3,3,3] [3] +-- "overflows" +-- (("sees","overflows"),[[1],[2,1],[2,1],[2,1],[2]]) +-- [1,3,3,3,2] +-- > naiveMultiplyIntegerSmall_ [3] [3,3,3,3] +-- "overflows" +-- (("sees","overflows"),[[1],[3],[3],[3],[2]]) +-- [1,3,3,3,2] +--When one argument is much bigger than the other, a relevant maximum +-- is 1+(min m n). Apparently when both arguments are pushing the limits, +-- the maximum is just (min m n). I'm sure that can be justified somehow. + + + +naiveMultiplyIntegerSmall_ i1 i2 = + collapseMassiveOverflow ({-sees "overflows" P.$ -} multiplyToOverflowing i1) + where + --as long as neither argument is zero, there should be no empty lists + --in this [Overflow] structure + multiplyToOverflowing :: [DInt]{-integer1-} -> [Overflow] + multiplyToOverflowing (d1:ds1) = zipCons (mulBySmall d1 i2) + (case multiplyToOverflowing ds1 of [] -> []; os@(_:_) -> [] {-!!!:-}: os) + multiplyToOverflowing [] = [] + collapseMassiveOverflow :: [Overflow] -> [DInt] + collapseMassiveOverflow x = + case x of + [] -> [] +--never trigger: +-- []:[] -> [] +-- []:overflows -> (dNat(0)) : collapseMassiveOverflow overflows + (overflow@(_:_)) : overflows -> + case quotRemByIntSmallBase (L.foldr1 (+) overflow) of + (high, low) -> {-traces high P.$ -} low !: + if isZero high then collapseMassiveOverflow overflows + else case overflows of + (o:os) -> collapseMassiveOverflow ((high:o):os) + [] -> assert + ("naive multiplication trails off nicely at the end" + ,overflow,high) (abs high < intSmallBase) + (high !: []) +--collapseMassiveOverflow (if isZero high then overflows else +-- case overflows of (o:os) -> (high:o):os; [] -> (high:[]):[]) +--} + +--precondition: neither argument is zero. Most-significant zeroes in arguments +-- will only mean that the result may have most-significant zeroes and the +-- computation may be significantly slower +naiveMultiplyIntegerSmall_ + :: SmallBaseLEList -> SmallBaseLEList -> SmallBaseLEList +{--optimizations? : +naiveMultiplyIntegerSmall_ (d1:[]) (d2:[]) = + case quotRemByIntSmallBase (d1 * d2) of--just (d1*d2):[] to create LargeBase + (high,low) -> low !: fromDInt high +naiveMultiplyIntegerSmall_ i1 (d2:[]) = mulBySmall d2 i1 +naiveMultiplyIntegerSmall_ (d1:[]) i2 = mulBySmall d1 i2 +naiveMultiplyIntegerSmall_ integer1 integer2 = + collapseMassiveOverflow (multiplyToOverflowing integer1) + where + --as long as neither argument is zero, there should be no empty lists + --in this [Overflow] structure... though since some digits may be zero, + --some of the dInts in the Overflows may be zero + multiplyToOverflowing :: [DInt]{-integer1-} -> [Overflow] + multiplyToOverflowing (d1:ds1) = zipCons (scaleInteger2 d1) + ([] : multiplyToOverflowing ds1) + multiplyToOverflowing [] = [] + scale d i = L.map (d *) i + scaleInteger2 d = scale d integer2 + --produces a well-behaved smallBase HInteger! + collapseMassiveOverflow :: [Overflow] -> [DInt] + collapseMassiveOverflow x = + case x of + [] -> [] +--never trigger: +-- []:[] -> [] +-- []:overflows -> (dNat(0)) !: collapseMassiveOverflow overflows + (overflow@(_:_)) : overflows -> + case determineDigitAndOverflow overflow of + (high, low) -> low !: collapseMassiveOverflow + (zipIntoHead high overflows) +--} + +--zipCons is something like zipWith (:), but has the proper behavior when +--either list argument ends (don't lose or add any elements). +zipCons :: [a] -> [[a]] -> [[a]] +zipCons [] xss2 = xss2 +zipCons (x1:xs1) (xs2:xss2) = (x1:xs2) : zipCons xs1 xss2 +zipCons xs1@(_:_) [] = L.map (:[]) xs1 +{-zipIntoHead :: [a] -> [[a]] -> [[a]] +zipIntoHead [] xss2 = xss2 +zipIntoHead xs1@(_:_) [] = xs1 : [] +zipIntoHead xs1@(_:_) (xs2:xss2) = (xs1 L.++ xs2) : xss2 + + +--type DiffList x = [x] -> [x] + +--needs commenting/description: +determineDigitAndOverflow :: Overflow -> {-[DInt] + -> -} {-DInt{-smallBase-} -> -} ({-DiffList-} Overflow, DInt) + -- maxSe14 = 2^14 - 1 --(all symmetric for negatives) + -- maxProduct = maxSe14 * maxSe14 + -- maxInt = 2^29 - 1 --potentially + --(maxProduct * 2 < maxInt), but (maxProduct * 3 > maxInt), + --so we can only add two products at a time +{-determineDigitAndOverflow (d:ds){- highs-} low = + case quotRemByIntSmallBase (low + d) of + (high,low_) -> + if isZero high + then determineDigitAndOverflow ds {-highs-} low_ + else determineDigitAndOverflow ds {-(high:highs) -}low_ +determineDigitAndOverflow [] highs low = (highs, low)-} +determineDigitAndOverflow = f (dNat(0)) []--(\x->x) + where + f dCurrent furtherOverflows [] = (furtherOverflows, dCurrent) + f dCurrent furtherOverflows (d:ds) = + case quotRemByIntSmallBase (dCurrent + d) of + (high,low) -> f low furtherOverflows_ ds + where + furtherOverflows_ = if isZero high --wouldn't be a problem + then furtherOverflows --not to weed out zeroes... + else high !: furtherOverflows +-- \x -> furtherOverflows (high:x) --order is immaterial... +--} +-- *** Karatsuba O(n^1.585)(for m approx.= n) multiplication ****** + +leadingZeroes :: PInt -> [DInt] -> [DInt] +--leadingZeroes n nil = if 0 == n then nil +-- else leadingZeroes n (zero !: nil) --zero !: leadingZeroes n nil +leadingZeroes howManyToAdd nil = f howManyToAdd + where + f n | (pNat(0)) == n = nil + f n = (dNat(0)) !: f (pred n) + +synergisticAddLeadingZeroes :: LargeBaseLEList -> LargeBaseLEList + -> PInt -> LargeBaseLEList +synergisticAddLeadingZeroes i1_ i2 zeroes_ = f i1_ zeroes_ + where + f i1 zeroes | (pNat(0)) == zeroes = synergisticAdd i1 i2 + f (d1:ds1) zeroes = d1 !: f ds1 (pred zeroes) + f [] zeroes = leadingZeroes zeroes i2 + +--avoiding fromIntegral... it involves the NInteger type, which +--might be us. +minSmallPDInt :: PInt -> DInt -> PInt +--minSmallPDInt p d = min p (fromIntegral d) +minSmallPDInt p d = f (pNat(0)) (dNat(0)) + where + f pThreshold dThreshold = + if p == pThreshold || d == dThreshold + then pThreshold + else f (succ pThreshold) (succ dThreshold) + +-- http://en.wikipedia.org/wiki/Karatsuba_algorithm +-- hmm, should we wait to convert to small base when we can +-- (or even convert to large base when starting with small) +-- so the recursion is less wasteful? +-- +-- <= this value = switch to naive / long multiplication +-- Hmm, although this karatsuba isn't incorrect and isn't slowing +-- it down a whole lot, it's not useful for "reasonable size" numbers. +-- I think division needs to be scrutinized for why it's slow. +-- Even with the estimate of ten digits as when karatsuba is worth it, +-- this still makes multiplication less than O(n^2), which is good. +karatsubaLargeBaseThreshold, karatsubaSmallBaseThreshold :: PInt +karatsubaLargeBaseThreshold = + minSmallPDInt (pNat(10)) intSmallBase --INTERESTING? + -- the min with intSmallBase is necessary, + -- see analysis before naiveMultiplyIntegerSmall_ + +karatsubaSmallBaseThreshold = pTwice karatsubaLargeBaseThreshold + +--no *0! +karatsubaMultiplyInteger_ :: HInteger__ -> PInt + -> HInteger__ -> PInt + -> HInteger__ +karatsubaMultiplyInteger_ i1 len1 i2 len2 = + let minLen = min len1 len2 in + if minLen <= karatsubaLargeBaseThreshold + then {-if (pNat(1)) == minLen then --shortNaiveMultiplyInteger i1 i2 else +--precondition: min (length i1) (length i2) == 1 +--shortNaiveMultiplyInteger :: HInteger__ -> HInteger__ -> HInteger__ +--shortNaiveMultiplyInteger i1@(d1:ds1) i2@(d2:ds2) = f ds1 ds2 + let + (d1:ds1) = i1 + (d2:ds2) = i2 + i1small = (pNat(1)) == len1 && abs d1 < intSmallBase + i2small = (pNat(1)) == len2 && abs d2 < intSmallBase + in if i1small then if i2small then (d1 * d2) !: [] + else smallToLargeBaseLEList (mulBySmall d1 (largeToSmallBaseLEList i2)) + else if i2small + then smallToLargeBaseLEList (mulBySmall d2 (largeToSmallBaseLEList i1)) + else smallToLargeBaseLEList + (naiveMultiplyIntegerSmall_ + (largeToSmallBaseLEList i1) + (largeToSmallBaseLEList i2)) + else-} + {-if 0 == minLen then [] else-} naiveMultiplyInteger_ i1 i2 + else let + b = pHalfRoundingDown (max len1 len2) --should we round up or down? + len1high = len1 - b + len2high = len2 - b + --hmm, should we chop any we find now? We're not particularly + --likely to find any... we assume that i1 and i2 have no + --most-significant zeroes + -- + --distance to split at named n (the list MUST BE at least this long). + --returns named ((length low, low), high). + --initially (non-recursive) must be called with n=b. + --Example: + --splitAtDroppingMostSignificantZeroes 6 + -- -- 1 2 3 4 5 6 7 8 9 + -- [0,2,0,4,0,0,0,8,0] + -- = ((4,[0,2,0,4]), [0,8,0]) + -- or return (number of) zeroesDropped instead of len? + splitAtDroppingMostSignificantZeroes :: PInt -> [DInt] + -> ((PInt, [DInt]), [DInt]) + splitAtDroppingMostSignificantZeroes n high + | (pNat(0)) == n = ((b,[]),high) +-- splitAtDroppingMostSignificantZeroes _ [] = MAY NOT happen + splitAtDroppingMostSignificantZeroes n (d:ds) = + --this is weird and complicated, can't we just do L.length + --and be about as efficient? + case splitAtDroppingMostSignificantZeroes (pred n) ds of + (lowInfo, high) -> + ( case lowInfo of + (maxLen, low_) -> + let + low = prepend d low_ + len = case low of [] -> b - n; (_:_) -> maxLen + in (len, low) + , high) +-- (if isZero d && L.null ds_ then (b - n,[]) else (len, d!:ds_), rest) +-- where +-- ((len,ds_),rest) = splitAtDroppingMostSignificantZeroes (pred n) ds + ((len1low, i1low), i1high) = splitAtDroppingMostSignificantZeroes b i1 + ((len2low, i2low), i2high) = splitAtDroppingMostSignificantZeroes b i2 + synergisticPlus = synergisticAdd + destructivePlus = destructiveAdd intLargeBase + neg = negateInteger + in + -- for the big * small cases ( <= rather than < is not + -- necessary, just convenient - it does eliminate some zeroes later) : + if len1high <= (pNat(0)) then let + y = karatsubaMultiplyInteger_ i1 len1 i2low len2low + z = karatsubaMultiplyInteger_ i1 len1 i2high len2high + in synergisticAddLeadingZeroes y z b + else if len2high <= (pNat(0)) then let + y = karatsubaMultiplyInteger_ i1low len1low i2 len2 + z = karatsubaMultiplyInteger_ i1high len1high i2 len2 + in synergisticAddLeadingZeroes y z b + else let + -- in case one (both?) of them happened to have lots of low digits be zero + -- nah, we'll just let that handle itself + --everywhere, we're either adding parts of i1, parts of i2, + --or parts of the answer, so the signs are always the same + --(except when they're always opposite because we're subtracting. + --Also zp is always >= magnitude than x and than y. + x = karatsubaMultiplyInteger_ i1high len1high i2high len2high + y = karatsubaMultiplyInteger_ i1low len1low i2low len2low + z1 = i1low `synergisticPlus` i1high + lenZ1 = L.length z1 + z2 = i2low `synergisticPlus` i2high + lenZ2 = L.length z2 + zp = karatsubaMultiplyInteger_ z1 lenZ1 z2 lenZ2 + -- or (zp `destructivePlus` (neg (x `synergisticPlus` y)) + z = (zp `destructivePlus` (neg x)) `destructivePlus` (neg y) + in synergisticAddLeadingZeroes y + (synergisticAddLeadingZeroes z x b) b +--associating the other way than this will be nicer: +-- ( (synergisticAddLeadingZeroes y z b) +-- `synergisticAddLeadingZeroes` x) (pTwice b) + +{- +karatsubaMultiplyIntegerSmall :: SmallBaseLEList + -> SmallBaseLEList + -> SmallBaseLEList +karatsubaMultiplyIntegerSmall i1 i2 = + let + len1 = pHalfRoundingUp len1Small --rounding up, as necessary + len2 = pHalfRoundingUp len2Small --rounding up, as necessary + len1Small = L.length i1 + len2Small = L.length i2 + minLenSmall = min len1Small len2Small + --roughly twice what it would be in LargeBase + in if minLenSmall <= karatsubaSmallBaseThreshold + then if (pNat(0)) == minLenSmall then [] + else naiveMultiplyIntegerSmall_ i1 i2 + else largeToSmallBaseLEList + (karatsubaMultiplyInteger_ (smallToLargeBaseLEList i1) len1 + (smallToLargeBaseLEList i2) len2) +-} + +--this version doesn't check for multiplying by zero, which +--mayn't be done with it! +karatsubaMultiplyIntegerSmall_ :: SmallBaseLEList + -> SmallBaseLEList + -> SmallBaseLEList +karatsubaMultiplyIntegerSmall_ i1 i2 = + let + len1 = pHalfRoundingUp len1Small --rounding up, as necessary + len2 = pHalfRoundingUp len2Small --rounding up, as necessary + len1Small = L.length i1 + len2Small = L.length i2 + minLenSmall = min len1Small len2Small + --roughly twice what it would be in LargeBase + in if minLenSmall <= karatsubaSmallBaseThreshold + then naiveMultiplyIntegerSmall_ i1 i2 + else largeToSmallBaseLEList ( + karatsubaMultiplyInteger_ + (smallToLargeBaseLEList i1) len1 + (smallToLargeBaseLEList i2) len2 + ) + + + +-- **** multiplications that should "normally" be used **** + +multiplyInteger :: HInteger__ -> HInteger__ -> HInteger__ +--hmm, optimizations. They seem to help slightly with my test set, +--which is to say, quite a lot more when the numbers are actually +--commonly small. +multiplyInteger (d1:[]) (d2:[]) = + let + (d1high,d1low) = quotRemByIntSmallBase d1 + (d2high,d2low) = quotRemByIntSmallBase d2 + in if isZero d1high && isZero d2high then (d1*d2) !: [] else + smallToLargeBaseLEList ( + naiveMultiplyIntegerSmall_ + (d1low !: fromDInt d1high) + (d2low !: fromDInt d2high) + ) +--checking for *0 is now required! +multiplyInteger [] _ = [] +multiplyInteger _ [] = [] +-- when it's nonzero and at least one argument is somewhat long: +multiplyInteger i1@(_:_) i2@(_:_) = karatsubaMultiplyInteger_ + i1 (L.length i1) + i2 (L.length i2) + +--neither argument may be zero, and it uses SmallBase. +--Just used internally in places where the arguments are not likely to be +--as small as one digit in length. +multiplyIntegerSmall_ :: SmallBaseLEList -> SmallBaseLEList -> SmallBaseLEList +multiplyIntegerSmall_ = karatsubaMultiplyIntegerSmall_ + + +-- 12 +-- 94 +-- --- +-- 8 +-- 18 +-- 4 +-- 9 +-- ----- +-- 1128 + +-- 99 +-- 99 +-- --- +-- 81 +-- 81 +-- 81 +-- 81 +-- ---- + + +-- **************************** DIVISION ************************* + +-- extendToN 3 [1] [4,5,6,7,8] +-- = [1,0,0,4,5,6,7,8] +-- Also ensures no-most-significant zeroes as long as neither +-- argument list had any. +-- length of the first list must not exceed targetLen. +extendToN, extendToN_ :: PInt -> [DInt] -> [DInt] -> [DInt] +extendToN targetLen l [] = + assert ("digits aren't overflowing",targetLen,l) (L.length l <= targetLen) + (l) +extendToN targetLen l nil = + assert ("digits aren't overflowing",targetLen,l,nil) (L.length l<=targetLen) + (extendToN_ targetLen l nil) +extendToN_ targetLen l nil = + assert ("digits_aren't_overflowing",targetLen,l,nil) (L.length l<=targetLen) + (f targetLen l) + where + f n _ | (pNat(0)) == n = nil + f n [] = leadingZeroes n nil + f n (x:xs) = x !: f (pred n) xs + +-- Wikipedia is not great at explaining long division, especially where the +-- denominator has >1 digit... http://en.wikipedia.org/wiki/Long_division +-- Long division essentially allows to reduce the size of the numerator. +-- Not the denominator. We choose not to do long division with >1digit +-- denominator because it's inefficient. + +--Either we break up the list beforehand and provide more reciprocal digits, +--because we are not always dividing as soon as possible, +--or we wait, and apply divide n times rather than n/d times (and depending +-- on the remainders, we may actually have to! so let's do the other). +--does not strip most-significant zeroes from quotient +{-longDivide :: (SmallBaseLEList{-long numerator digit-} + -> (SmallBaseLEList{-quot-}, SmallBaseLEList{-rem-})) + -> [SmallBaseLEList{-long numerator digits-}] + -> (SmallBaseLEList{-quotient-}, + SmallBaseLEList{-remainder <= maximum rem-} +longDivide divide [] = ([],[]) -- zero divided by anything +longDivide divide (n:ns) + = let + (q,r) = divide n + longDivide + in +--may be used in base 2^(14*8) :)) +--concat quotient may be used if quots all have the appropriate +--number of most-significant zeroes... +longDivideBySingleDigit :: (digit{-long numerator digit or two-} + -> (digit{-quot-}, digit{-rem-})) + -> [digit{-long numerator digits-}] + -> ([digit]{-quotient-}, digit{-remainder <= maximum rem-}) +longDivideBySingleDigit divide [] = ([],[]) -- zero divided by anything +longDivideBySingleDigit divide (n:ns) + = let + (q,r) = divide n + (qs,) = longDivide divide ns r + in qs ++ [q] + in-} + +--first what must be done is dropping low-order numerator +--digits to increase the? seems unlikely... +--assumes not dividing by zero +--May produce most-significant zeroes, currently. +longDivideBySingleDigit :: + {- (digit -> Bool) -> -- ^ isZero, not strictly necessary + --but allows us to easily eliminate most-significant zeroes-} + --these quotRem functions already know the denominator somehow: + (digit{-only low (high=0)-} -> (digit{-quot-},digit{-rem-})) + -> (digit{-high-} -> digit{-low-} -> (digit{-quot-},digit{-rem-})) + -> [digit] -> ([digit], digit) +longDivideBySingleDigit {-isZero1-} quotRemBy1 quotRemBy2 = f + where + f (d:[]) = case quotRemBy1 d of (q,r) -> (q{-!!!:-}:[], r) --hmm + f (d:ds) = + case f ds of + (qs, prevRem) -> + case quotRemBy2 prevRem d of + (q,r) -> (q{-!!!:-}:qs, r) +-- digit has to be (at least?) as big as the size of the denominator. +-- the size of the remainders is limited by the size of the denominator. + +--assumes not dividing by zero +--if the list-argument has no most-significant zeroes and doesn't contain +--digits of opposite signs, the result contains no most-significant zeroes. +longDivideBySmall :: DInt{- SmallBaseLEList + -> (SmallBaseLEList{-quot-},DInt{-rem-}) +longDivideBySmall denom = f + where + f [] = ( [], (dNat(0)) ) + f (d:[]) = case d `quotRem` denom of + (q,r) -> ( fromDInt q , r ) + --this check is sufficient because/when d is nonzero + --and denom is smaller than the base, so then the + --remainder here is nonzero and survives in the + --previous digit (if any) + f (d:ds) = + case f ds of + (qs, prevRem) -> + case (highLowFromIntSmallBase prevRem d) `quotRem` denom of + (q,r) -> (q:qs, r) + +--only for large base, and doesn't check for the error of dividing by zero. +quotRemInteger :: HInteger__ -> HInteger__{-nonzero-} + -> (HInteger__, HInteger__) +-- must come first: even zero divided by zero is erroneous +-- _ `quotRemInteger` [] = assert "quotRemInteger used to divide by zero" +-- False (zeroInteger, zeroInteger) +-- other than that, zero divided by anything is trivial +[] `quotRemInteger` _ = (zeroInteger, zeroInteger) +-- it should go much faster on not-too-big size things +-- to use DInt's native quotRem without further ado +(num:[]) `quotRemInteger` (denom:[]) = + case num `quotRem` denom of + (q,r) -> ( fromDInt q, fromDInt r ) +-- divisions by 1 and -1 must not be passed along +num `quotRemInteger` (denom:[]) + | denom == (dNat(1)) = ( num, zeroInteger) + | denom == (dNeg(1)) = (negateInteger num, zeroInteger) + -- | abs denom == (dNat(1)) = (L.map (denom *) num, zeroInteger) +--quotRemSmallBase will optimize the abs denominator>abs numerator case (hmm) +--and the small-denominator, large numerator case particularly too. +num `quotRemInteger` denom = + case largeToSmallBaseLEList num + `quotRemSmallBase` largeToSmallBaseLEList denom of + (q,r) -> (smallToLargeBaseLEList q, smallToLargeBaseLEList r) + +--assumes not dividing by zero (or by 1 or by -1?) +--should I make special cases for 0 1 -1 outside and +--remove the checks from reciprocalToPrecision? yep +quotRemSmallBase, quotRemSmallSectioned--, quotRemSmallGulp + :: SmallBaseLEList -> SmallBaseLEList + -> (SmallBaseLEList, SmallBaseLEList) +-- 'num' is short for 'numerator' here, also denom for denominator +num `quotRemSmallBase` (denom:[]) +-- | abs denom < intSmallBase --of course it is, since this is _in_ SmallBase! +--optimization for small denominator + = case longDivideBySmall denom num of + (q,r) -> ( q , fromDInt r ) +num `quotRemSmallBase` denom = + --don't do anything stupid in this trivial case + --(we could be more precise and check their magnitudes...) + -- if lenDenom > lenNum then (zeroInteger, num) + case compareAbsInteger num denom of + LT -> (zeroInteger, num) + --EQ -> (+-oneInteger, zeroInteger) + _ -> num `quotRemSmallSectioned`{-Gulp`-} denom + +dropMostSignificantZeroes :: [DInt] -> [DInt] +dropMostSignificantZeroes [] = [] +dropMostSignificantZeroes (d:ds) = prepend d (dropMostSignificantZeroes ds) + +--some version of the sectioned code: +-- ./CheckIntegerInTermsOfInt 123.34s user 0.26s system 98% cpu 2:05.19 total +-- ./CheckIntegerInTermsOfInt 123.44s user 0.46s system 98% cpu 2:05.60 total +num `quotRemSmallSectioned` denom = + quotRemSmallSectioned_ denom (minimalReciprocal denom) num + +minimalReciprocal :: SmallBaseLEList -> (SmallBaseLEList,PInt) +minimalReciprocal denom = + reciprocalToPrecision (succ (pTwice (L.length denom))) denom + +quotRemSmallSectioned_ :: + SmallBaseLEList -> (SmallBaseLEList,PInt) + -> SmallBaseLEList + -> (SmallBaseLEList, SmallBaseLEList) +quotRemSmallSectioned_ denom (recipDigits,recipExp) = +-- assert ("quotRemSmallBase not dividing by zero",denom) +-- (not (L.null denom)) P.$ +-- assert ("denominator has no most-significant zeroes",denom) +-- (L.null denom || (dNat(0)) P./= (L.last denom)) P.$ +-- assert ("numerator has no most-significant zeroes",num) +-- (L.null num || (dNat(0)) P./= (L.last num)) P.$ + let + lenDenom = L.length denom + --they're not necessarily all the same length anyway because of the + --most-significant digits: + split [] = [] + split l = let (digit, rest) = L.splitAt lenDenom l + in dropMostSignificantZeroes digit {-!!!:-}: split rest + join [] = [] + join (x:xs) = extendToN lenDenom x (join xs) + negDenom = negateInteger denom + quotRemBy1 moderateSizeNum = + -- traces ("qrb1",moderateSizeNum) P.$ +-- assert ("expected length digits",moderateSizeNum,lenDenom) +-- (L.length moderateSizeNum <= pTwice lenDenom{-quotRemBy2-}) P.$ +-- assert ("moderateSizeNumerator has no most-significant zeroes", +-- moderateSizeNum) +-- (L.null moderateSizeNum || (dNat(0)) P./= (L.last moderateSizeNum)) P.$ + case moderateSizeNum of + [] -> ([],[]) -- zero digit divided by something = 0, remainder 0 + (_:_) -> --now we can use nonzero multiplication + let + quotient = L.drop recipExp + (moderateSizeNum `multiplyIntegerSmall_` recipDigits) + remainder = case quotient of + [] -> moderateSizeNum -- quotient=0 ==> remainder= the whole thing. + -- Remainder = moderateSizeNumerator - (quotient * denominator) : + -- The remainder is certainly no greater than the numerator here, + -- so it's safe to consider it a destructive add/subtraction + (_:_) -> destructiveAdd intSmallBase + (moderateSizeNum) + (quotient `multiplyIntegerSmall_` negDenom) + in + -- traces ("qrb1'",(recipExp,recipDigits,negDenom), + -- (moderateSizeNum,quotient)) P.$ +-- assert ("okay length quotient",quotient,lenDenom) +-- (L.length quotient <= lenDenom) P.$ +-- assert ("len remainder",remainder,lenDenom) +-- (L.length remainder <= lenDenom) P.$ +-- assert ("quotient has no most-significant zeroes" +-- ,quotient,(remainder,moderateSizeNum),(num,denom)) +-- (L.null quotient || (dNat(0)) P./= (L.last quotient)) P.$ +-- assert ("remainder has no most-significant zeroes" +-- ,(remainder,moderateSizeNum),quotient,(num,denom)) +-- (L.null remainder || (dNat(0)) P./= (L.last remainder)) P.$ + --remainder sign may vary with sub-parts- hmm.... is that true? + --The digit-parts of the split numerator should all be the same sign + --(or zero). +-- assert ("remainder size",remainder,denom) +-- (L.length remainder < lenDenom || (L.length remainder == lenDenom && +-- L.map abs (L.reverse remainder) < L.map abs (L.reverse denom))) P.$ + (quotient, remainder) + quotRemBy2 highNum{-a remainder-} lowNum = + -- traces ("qrb2",highNum,lowNum) P.$ +-- assert ("lowNum fits",lowNum) (L.length lowNum <= lenDenom) P.$ +-- if L.null highNum then quotRemBy1 lowNum else + quotRemBy1 (extendToN lenDenom lowNum highNum) + in \num -> + case longDivideBySingleDigit quotRemBy1 quotRemBy2 (split num) of + (quotDigits,remDigit) -> (join quotDigits, remDigit) + +{-- +-- ./CheckIntegerInTermsOfInt 178.31s user 0.32s system 99% cpu 2:58.87 total +num `quotRemSmallGulp` denom = let + (recipDigits,recipExp) = + reciprocalToPrecision (succ (L.length num + L.length denom)) denom + quotient = L.drop recipExp (num `multiplyIntegerSmall_` recipDigits) + remainder = {-case quotient of + [] -> num -- quotient=0 ==> remainder= the whole thing. + --(we could check for too-big denominator (precisely) earlier...) + -- Remainder = moderateSizeNumerator - (quotient * denominator) : + -- The remainder is certainly no greater than the numerator here, + -- so it's safe to consider it a destructive add/subtraction + (_:_) -> -} destructiveAdd intSmallBase + (num) + (quotient `multiplyIntegerSmall_` negateInteger denom) + in (quotient,remainder) +--} + + + +{- +--The first argument, 2 . 0 0 0 0 , is implicit because we can deduce it +--from knowing that the second argument is between 0.5 and 1.5 (roughly), +--as demonstrated by the second argument's patterns (and this means +--we don't have to figure out how to find the value of the 2, also!). +--Otherwise the implementation is very similar to destructive_'s +--implementation, whose cases are referenced GT/EQ/LT. + --base cases +sub (2:[]) ( 1 : []) = 1 !: [] +sub (0:2:[]) (d>1: []) = base - d !: (1 !: []) +--GT[destructive/sub] is impossible considering all the zeroes on the left +sub (0:x) ( 0 : ds) = 0 !: minus (x) ds --EQ +sub (0:x) ( d : ds) = base - d !: borrow (x) ds --LT + + --base cases +subBorrow (2:[]) ( 1 : []) = 1 - 1 !: [] +subBorrow (0:2:[]) (d>1: []) = base - d - 1 !: (1 !: []) +--GT and EQ are impossible considering zeroes borrowed from, on the left. +subBorrow (0:x) ( d : ds) = base - d - 1 !: borrow (x) ds --LT + + --as soon as borrowing/carrying begins, it must continue + --until we reach the point where '2' provides anything nonzero + -- 2 - 1.00001 = 0.????? ; 2 - 0.99999 = 1.?????? + -- This requires that intSmallBase be sufficiently big. + -- 1.9 and 0.1 are just NOT ALLOWED to happen + -- (they would cause trouble, and are quite poor estimates) +-} +twoMinusSomethingNearOne :: {-base:: -}DInt -> [DInt] -> [DInt] +twoMinusSomethingNearOne base = sub_2 + where + sub_2, subBorrow_2 :: SmallBaseLEList -> SmallBaseLEList + sub_2 (d:[]) = if (dNat(1)) == d then oneInteger else + (base - d) !: oneInteger + sub_2 (d:ds) = if isZero d then (dNat(0)) !: sub_2 ds else + (base - d) !: subBorrow_2 ds + subBorrow_2 (d:[]) = if (dNat(1)) == d then zeroInteger else + pred (base - d) !: oneInteger + subBorrow_2 (d:ds) = + pred (base - d) !: subBorrow_2 ds + +type FloatingInteger = (SmallBaseLEList, PInt) +-- (i, e); i /= 0; e >= 0 (is e always >= 0 ??) +-- represents the value +-- (i * (smallBase ^ (negate{-??-} e))) +-- Sometimes they are normalized by turning least-significant +-- zeroes into larger exponents. + +--input: not zero, not one, not negative one. +--output: no most-significant zeroes, possibly has least-significant zeroes. +-- exactness doesn't matter, we just need a sufficiently good +-- estimate (for some particular definition of "sufficiently good") +reciprocalEstimate :: SmallBaseLEList -> FloatingInteger +reciprocalEstimate = rE (pNat(0)) + where + toBase d = largeToSmallBaseLEList (d !: []) + largeOver n e = ( toBase (intLargeBase `quot` n) + , (pNat(2)){-for largeBase factor-} + e + ) + --very small ( < smallBase ) numbers get simple estimates + --(actually this function is never used on them + --since there's a faster division method for small denominator, + --so this could be commented out :) + rE e ( d : [] ) = largeOver d e + --the rest get counted down + rE e ( _ :(ds@(_:(_:_)))) = rE (succ e) ds + --and the result with most precision chosen + rE e (low: high : [] ) = + if high * high >= intSmallBase --high > sqrt intSmallBase + -- at this point n references smallBase*high+low, so just 'high' + -- is a factor of intSmallBase less than that, + then largeOver high (succ{-for failing to *smallBase-} e) + else largeOver (highLowFromIntSmallBase high low) e + +--an exact function? +--naive +--recip This Much Precision +--(places after radix point, or after the first nonzero digit?) + +--This may be the only place that the precision of DInt (rather than +--available memory) limits the length of an Integer!!! Also, using +--Prelude.drop/take requires Prelude.DInt +--I guess the required precision only refers to accuracy, not having +--a bunch of unneeded trailing zero digits in the answer if the answer +--turns out round like that. likewise, some extra precision in result +--(een if it's wrong) is not forbidden? expected rounding = give more +--precision? that may not be enough (see analysis below) -- it is, +--round up +--DO NOT PASS 0, 1 or -1 to take the reciprocal of! +reciprocalToPrecision :: PInt{-smallBase-digits required after radix point + (should be one more than you might think, as we'll round up...?)-} + -> SmallBaseLEList{-to take the reciprocal of-} + -> FloatingInteger +--internally we need to use... we'll try some things? +--Newton-Raphson method +--http://en.wikipedia.org/wiki/Newton%27s_method +--specific to getting more and more precise reciprocal digits +--(solving, for a known x, r = 1/x (a hyperbola) (1/x - r = 0) +--The specific instantiation used here, r_(n+1) = r_(n) * (2 - x * r_(n)), +--appears in a similar form (replace y with 2y-xy^2) on +-- http://en.wikipedia.org/wiki/Reciprocal_%28mathematics%29 +-- . We get our initial estimate from a native DInt division. +reciprocalToPrecision resultPrecision reciprocee = + dropExcessPrecisionRoundingUpInMagnitude resultPrecision + (doSeries + (dropLeastSignificantZeroes + (reciprocalEstimate reciprocee))) + where + doSeries = fixPointBy (==) (\(i,e) -> (e, makeShort i)) nextIter + where + --only to be fast and checkable for equality: + makeShort i = L.take resultPrecision (L.reverse i) + + -- e*(2-i*e) + nextIter :: FloatingInteger -> FloatingInteger + nextIter (estimate, estimateExp) = + dropExcessPrecisionRoundingUpInMagnitude internalPrecision + ( dropLeastSignificantZeroes + ( estimate `times` (twoMinus (reciprocee `times` estimate)) + --estimateExp + (id ( 0 + estimateExp)) + , pTwice estimateExp -- equivalent to above. + --Multiplication adds exps; reciprocee is exp 0; + -- twoMinus doesn't change exp. + ) + ) + where + internalPrecision = pTwice resultPrecision + --2 > (n * estimated reciprocal of n) > 0, MUST be true. + --(the estimate has to be good enough, that is) + --so subtracting is destructive and yields an overall-positive answer. + twoMinus = twoMinusSomethingNearOne intSmallBase + times = {-if internalPrecision > karatsubaSmallBaseThreshold + then-} multiplyIntegerSmall_ --yep, no factors should be zero here + -- else naiveMultiplyIntegerSmall_ + +fixPointBy :: (canon -> canon -> Bool) -> (a -> canon) -> (a -> a) -> a -> a +fixPointBy eqCanon canonicalizer iter initial = + f (canonicalizer initial) initial + where + f canonic value = let + value_ = iter value + canonic_ = canonicalizer value_ + in if eqCanon canonic canonic_ then value_ else f canonic_ value_ + +countingDropWhile :: (a -> Bool) -> [a] -> (PInt, [a]) +countingDropWhile p = f (pNat(0)) + where + f n (x:xs) | p x = f (succ n) xs + f n l = (n, l) + --f n [] = (n, []) + --f n l@(x:xs) = if p x then f (succ n) xs else (n, l) + +dropLeastSignificantZeroes + :: FloatingInteger -> FloatingInteger +dropLeastSignificantZeroes (d,e) = case countingDropWhile isZero d of + (de, d_) -> (d_, e - de) + -- requires dropLeastSignificantZeroes-effect first. + -- hmm, is something with least-significant zeroes allowed? certainly +dropExcessPrecisionRoundingUpInMagnitude + :: PInt -> FloatingInteger -> FloatingInteger +dropExcessPrecisionRoundingUpInMagnitude precis ie@(i@(int:_), e) = + let nToDrop = (L.length i) - precis in + -- if the "rounding up" causes an extra digit, then + -- the exponent remains the same, but the number is + -- ... 0 !: 0 !: 0 !: 0 !: +-1 !: []. Fewer least-significant + -- zeroes can also be created by less-extreme carrying. + -- Either way these are eliminated by dropLeastSignificantZeroes. + if nToDrop > (pNat(0)) + then + --should we dropLeastSignificantZeroes first too (otherwise + --this "might" unnecessarily keep the precision long, dependently + --on meaningless stuff, which would be bad) + --Er, _should_ we doing weird rounding-up like this on every step + --of Newton's? well, the alternative is implicitly rounding down ;) + --(unless we want to really slow things down by keeping all the + --digits, which doesn't seem necessary...) + dropLeastSignificantZeroes --add AFTER drop? + ( synergisticAddOnlyCarrySmall (L.drop nToDrop i) (signum int) + , e - nToDrop + ) + else ie --if it is already within precision, we have no + --safe way of "rounding up" without extending the precision, + --which would be meaningless. It's pretty much exact here. + +--reciprocalOfNDigits :: DInt{-=length digits(?)-} +-- -> SmallBaseLEList{-digits-} +-- -> ( +-- SmallBaseLEList{-number of reciprocal digits that is required-} +-- , DInt) + {-length rdigits = length digits + +(0.09 = 0.1 = 10^-1) * 9 < 1 +the numerator may be up to one more digit than the denominator +in each division in a long division: + + 0065 r 5 --6=quot,5=quot,5=rem + --------- +43|2800 --not shown: 0,2=quotRem; 0,28=quotRem + 258 + --- + 220 --22=rem + 215 + --- + 5 --5=rem + +and ((d+1) over d) = (d+1) * recip d +9 requires 0.2 but not 0.09999999999999... +99 requires 0.02 but not 0.00999999999999... +If we assume all reciprocals will be less in magnitude than 1 + (we can check for 0, 1, -1 denominators in advance, or just +do that implicitly by specializing for one-or-less-digit denominators) +and only count the digits _after_ the decimal point, that makes us +need only as many digits in the result as in the sub-numerator; i.e., d+1. + +Of course we may need more digits temporarily, in order +to find the reciprocal to that precision. + +342787745 / 3 +qr 3 3 = (1,0) +qr 04 3 = (1,1) +qr 12 3 = (4,0) +qr 07 3 = (2,1) +qr 18 3 = (6,0) +qr 07 3 = (2,1) +qr 17 3 = (5,2) +qr 24 3 = (8,0) +qr 05 3 = (1,2) +114262581 + 2/3 +but it is simple: convert to however large a base is needed for the +denominator to fit, then do repeated quotRem. It is the previous remainder +that contributes most of the difficulty in the digit-division. + +3/3 = 3*0.333333 = 0.999999 = 0 +6/6 = 6*0.16 = 0.96 + 0.166 0.996 + 0.1666 0.9996 +8/9 = 8*0.111111 = 0.888888 +2/2 = 2*0.500000 = 1.000000 = 0 +9/9 = 9*0.111111 = 0.999999 + = 1*0.999999 +perhaps round _up_ (or even, +1) the last, insignificant digit always, +then round _down_ the product? (careful with adding to negative numbers) + +we require numeratorDigits after radix point, plus one that is incremented +from the correct value (this last digit may be max possible first, in which +case it carries.) (just adding 1 to the last of numeratorDigits + seems to work?) + +we happen to choose our numeratorDigits to be up to (twice) +denominatorDigits (I think) (it just requires enough that the recip has any +digits and can be used?) + + +-} + + +-- ********************** CONVERSION ************************ +-- between HInteger and other numerical types + + +-- We are interested in small code footprint anyway so it's fine +-- if they aren't noticed by some compilers. They are used to +-- define these more specific types in some instances, though. +-- This pragma is even described by Haskell-98! +-- Using Bits (INTERESTING?), from/to DInt may be implemented +-- rather differently... +{-# SPECIALIZE versatileFromIntegral :: N.Int -> HInteger__ #-} +{-# SPECIALIZE uncheckedFromIntegral :: N.Int -> HInteger__ #-} +{-# SPECIALIZE uncheckedFromIntegral :: N.Integer -> HInteger__ #-} +{-# SPECIALIZE uncheckedToNum :: HInteger__ -> N.Int #-} +{-# SPECIALIZE uncheckedToNum :: HInteger__ -> N.Integer #-} + +--hmm. or toInteger, which must be implemented _somehow_ in Integrals? +versatileFromIntegral :: Integral a => a -> LargeBaseLEList +versatileFromIntegral integral = + -- fromIntegral = fromInteger . toInteger; the toInteger's + -- implementation is not our responsibility, as long as + -- no exported function relies on the one we're defining here, and + -- DInt's fromInteger::Integer->DInt doesn't depend on x->Integer either. + if Misc.fromIntegral integralLargeBase_ /= intLargeBase + --presumably the integral is small enough to fit in DInt + -- if intLargeBase did not fit in it + --(this might fail for "NonPositiveInteger" or so...) + then uncheckedFromIntegral (integralToDInt_ integral) + else fromIntegral_ integral + where + -- locally monomorphic type matches argument, + -- and this computation is shared. (This implementation + -- will fail for bounded types in which intLargeBase doesn't fit, + -- so we try to detect that problem - above.) + integralLargeBase_ = Misc.fromIntegral intLargeBase + integralIsZero_ = (0 ==) + integralToDInt_ = Misc.fromIntegral + fromIntegral_ = + \i -> if integralIsZero_ i then [] else + case i `quotRem` integralLargeBase_ of + (above, digit) -> integralToDInt_ digit !: fromIntegral_ above + +-- intLargeBase must fit in the Integral type - not checked. +uncheckedFromIntegral :: Integral a => a -> LargeBaseLEList +uncheckedFromIntegral integral = fromIntegral_ integral + -- fromIntegral = fromInteger . toInteger; the toInteger's + -- implementation is not our responsibility, as long as + -- no exported function relies on the one we're defining here, and + -- DInt's fromInteger::Integer->DInt doesn't depend on x->Integer either. + where + -- locally monomorphic type matches argument, + -- and this computation is shared. + integralLargeBase_ = Misc.fromIntegral intLargeBase + integralIsZero_ = (0 ==) + integralToDInt_ = Misc.fromIntegral + fromIntegral_ = + \i -> if integralIsZero_ i then [] else + case i `quotRem` integralLargeBase_ of + (above, digit) -> integralToDInt_ digit !: fromIntegral_ above + +--Does not check for overflow. after all, bounded is not a superclass +--of num, integral or enum (consider Integer!). However it is not as unsafe +--as uncheckedFromIntegral, because it wasn't a very meaningful operation +--anyway, when uncheckedToNum overflows. +uncheckedToNum :: Num a => LargeBaseLEList -> a +uncheckedToNum [] = 0 +uncheckedToNum integer@(_:_) = toIntegral_ integer + where + integralLargeBase_ = Misc.fromIntegral intLargeBase + intToIntegral_ = Misc.fromIntegral + toIntegral_ = + \(d:ds) -> case ds of + [] -> intToIntegral_ d + _ -> intToIntegral_ d + integralLargeBase_ * toIntegral_ ds + +{- +instance Num Int / fromInteger will have to be implemented somehow +when we are the native integer. +uncheckedToNum works fine internally... we should export +intFromInteger :: HInteger -> PInt +from the exterior module. + +-- the integer must be fully organized like it was in an Integer, +-- to call toIntInteger +toIntInteger :: LargeBaseLEList -> Int +--if we assume two's-complement Bits the implementation is +--rather different +toIntInteger [] = zero +toIntInteger (d:[]) = d --good for the common case +toIntInteger integer = + --When the integer doesn't fit in an int... + --we could do an overflow error, like Hugs, + -- or a modulus / bit-chopping, like GHC.. what is right? + -- Hugs still implements wrapping ((maxBound + maxBound :: Int) /= _|_) + -- and a third option is to just do something like + -- uncheckedToIntNonZeroInteger even if it would overflow like that + uncheckedToIntNonZeroInteger integer +{- + if CInteger integer <= maxIntInteger && CInteger integer >= minIntInteger + then uncheckedToIntNonZeroInteger integer + else + overflowError +-} +{- + let + shortened = CInteger integer `mod` toIntModulus + in if shortened > maxIntInteger + then uncheckedToIntNonZeroInteger + (case shortened - maxIntInteger of CInteger i -> i) + else uncheckedToIntNonZeroInteger + (case shortened of CInteger i -> i) +-} +uncheckedToIntNonZeroInteger :: LargeBaseLEList -> Int +uncheckedToIntNonZeroInteger (d:[]) = d +uncheckedToIntNonZeroInteger (d:ds) = d + + intLargeBase * uncheckedToIntNonZeroInteger ds +toIntModulus = maxIntInteger - minIntInteger +maxIntInteger, minIntInteger, toIntModulus :: Integer +maxIntInteger = Misc.fromIntegral (maxBound :: Int) +minIntInteger = Misc.fromIntegral (minBound :: Int) +--how is overflow handled? we could use maxBound,minBound +--(are those required to be closely related?), Bits... +-} + + + + +-- ********************** EXPORTED ********************** ... + + +intFromInteger :: Integer -> PInt +intFromInteger (CInteger a) = uncheckedToNum a +integerFromInt :: PInt -> Integer +integerFromInt int = mkInteger ( + --if PInt == DInt + --(if we knew PInt had as big a capacity as DInt (it is the very same type + --except in some testing circumstances!), we could use uncheckedFromIntegral + --here) : + --uncheckedFromIntegral --INTERESTING + --if PInt might have a rather smaller capacity than DInt + versatileFromIntegral + int ) + +-- ... including the ***** Integer type **** ... + +--(Little-endian does not mean the machine Ints have to be +-- stored any particular way!) +--They are represented as a little-endian list of +--quantities in base N. What is N? Unless customized otherwise, +--this is 2^28 for minimal (30-bit) Haskell-98 Ints, 2^30 for 32-bit Ints, +--2^62 for 64-bit Ints, etc. - the maximal power of four that works, see below +--for details. Negative numbers have all elements of the list be negative. +--So, for each int d in the list: -base < d < base. +--"Leading" zeroes (those at the end of the list) are not permitted. +--(so 0 == Integer []). This form should not be too much +--of a burden for compilers to produce (as they must for +--[at least, large] numeric literals), since they can already +--do String::[Char], and we are assuming they can support Int well. +--Examples (assuming base 2^28) : +-- 0 is [] +-- 0xfffffff is 0xfffffff : [] +-- -0xfffffff is -0xfffffff : [] +-- 0x10000000 is 0 : 1 : [] +-- -0x10000000 is 0 : -1 : [] +newtype Integer = CInteger { unI :: LargeBaseLEList } + + +--no need for strictness annotations in interpreter, +--and a smart enough compiler might figure them out? +--For now, instead of carefully examining all the code +--this should be semantically correct.......... +--Now I believe all the code is strict enough! of course if the assertion +-- is tested, that will also force the whole list... +mkInteger :: LargeBaseLEList -> Integer +mkInteger integer = --eval integer `seq` + assert ("mkInteger validity",integer) (validBase intLargeBase integer) + (CInteger integer) +-- where +-- eval :: LargeBaseLEList -> () +-- eval (d:ds) = d `seq` eval ds +-- eval [] = () + + + +-- ... and ******* INSTANCES ****** ... + +--or, could be derived...: +instance Class.Eq Integer where + CInteger a == CInteger b = a == b + +instance Class.Ord Integer where + compare (CInteger a) (CInteger b) = compareInteger a b + +instance Class.Num Integer where + CInteger a + CInteger b = mkInteger (addInteger a b) + -- (-) is default based on negate and (+) + CInteger a * CInteger b = mkInteger (multiplyInteger a b) + negate (CInteger a) = mkInteger (negateInteger a) + abs (CInteger a) = mkInteger (absInteger a) + signum (CInteger a) = mkInteger (signumInteger a) + + --fromInteger :: NInteger -> HInteger + --Can be used when we are the native integer, which improves + -- efficiency but is not necessary: + --fromInteger integer = integer --INTERESTING + fromInteger unboundedIntegral = mkInteger + (uncheckedFromIntegral unboundedIntegral) + + --can be used when fromInt exists, + -- though it's not very useful anyway + --fromInt :: DInt -> HInteger + --fromInt = integerFromInt + +instance Class.Real Integer where + --toRational :: HInteger -> Ratio NInteger + --INTERESTING + -- if we are the native integer + -- toRational i = i % oneInteger --hmph, requires importing (Data.)Ratio... + -- toRational = fromInteger + toRational = Misc.fromIntegral + +--INTERESTING? "messages" are the same as hugs'. +divZeroError :: a +divZeroError = --{-hmm-}((dNat(1)) `div` (dNat(0))) `seq` + Error.error "divide by zero" +--overflowError :: a +--overflowError = {-hmm-} Error.error "arithmetic overflow" + +instance Class.Integral Integer where + --toInteger :: HInteger -> NInteger + -- if we are the native integer + --toInteger i = i + toInteger (CInteger a) = uncheckedToNum a + CInteger a `quotRem` CInteger b = + if isZeroInteger b + then divZeroError + else case a `quotRemInteger` b of + (q,r) -> (mkInteger q, mkInteger r) + +--possibly could be made more efficient: +succInteger, predInteger :: HInteger__ -> HInteger__ +succInteger i = addInteger i oneInteger +predInteger i = addInteger i negativeOneInteger + +instance Class.Enum Integer where + succ (CInteger a) = mkInteger (succInteger a) + pred (CInteger a) = mkInteger (predInteger a) + enumFrom a = a : enumFrom (succ a) + enumFromThen a b = eF a + where add = b - a; next = (add +); eF a_ = a_ : eF (next a_) + enumFromTo a e = eF a + where eF a_ = if e < a_ then [] else a_ : eF (succ a_) + enumFromThenTo a b e = eF a + where + add = b - a; next = (add +) + eF a_ = if e < a_ then [] else a_ : eF (next a_) + --toEnum :: PInt -> HInteger + toEnum = integerFromInt + --fromEnum :: HInteger -> PInt + fromEnum = intFromInteger + + + + + +{- +--THIS ONE WORKS WITH ANY POSITIVE BASE WHATSOEVER +--but the argument being split, must be positive (not zero) +--and the resulting list is most-significant first(?) +convertPositiveToBase :: Integer -> Integer -> [Integer] +convertPositiveToBase base = jsplitf base + where + jsplitf :: Integer -> Integer -> [Integer] + jsplitf p n = if p > n + then n : [] + else jsplith p (jsplitf (p * p) n) + + jsplith :: Integer -> [Integer] -> [Integer] + jsplith p (n:ns) = + case n `quotRem` p of + (q,r) -> if 0 == q + then r : jsplitb p ns + else q : r : jsplitb p ns + + jsplitb :: Integer -> [Integer] -> [Integer] + jsplitb _ [] = [] + jsplitb p (n:ns) = case n `quotRem` p of + (q,r) -> q : r : jsplitb p ns +-} + + +instance Class.Show Integer where +-- libraries/base/GHC/Num.lhs has a pretty fancy implementation +-- which we could duplicate if we wanted. +-- I'm afraid that even if we have O(n) division-by-10, +-- iterated O(n) times, show is O(n^2) here. + showsPrec _ (CInteger []) r = '0':r + showsPrec p (CInteger (d:[])) r = showsPrec p d r + showsPrec p (CInteger integer) r + = if isNeg && p > (pNat(6)) + then '(' : showsSignInteger isNeg positiveInteger (')' : r) + else showsSignInteger isNeg positiveInteger r + where + isNeg = compareNonzeroIntegerZero integer == LT + positiveInteger = if isNeg then negateInteger integer else integer + +showsSignInteger :: Bool -> LargeBaseLEList -> String -> String +showsSignInteger isNeg positiveInteger cs = + if isNeg then '-' : showsPositiveInteger positiveInteger cs + else showsPositiveInteger positiveInteger cs + +showsPositiveInteger :: LargeBaseLEList -> String -> String +{-- +showsPositiveInteger integer cs = P.dropWhile (== '0') P.$ + P.foldr myshows cs (convertPositiveToBase (1000000000) (CInteger integer)) + where + myshows i = jblock (P.fromIntegral{-hmm-} i) + jhead :: P.Int -> String -> String + jhead n cs + = if n < 10 + then case {-unsafeChr-}toEnum ({-ord-}fromEnum '0' + n) of + c -> c `seq` (c : cs) + else case {-unsafeChr-}toEnum ({-ord-}fromEnum '0' + r) of + c -> c `seq` (jhead q (c : cs)) + where + (q, r) = n `quotRem`{-Int`-} 10 + + jblock = jblock' {- ' -} 9 + + jblock' :: P.Int -> P.Int -> String -> String + jblock' d n cs + = if d == 1 + then case {-unsafeChr-}toEnum ({-ord-}fromEnum '0' + n) of + c -> c `seq` (c : cs) + else case {-unsafeChr-}toEnum ({-ord-}fromEnum '0' + r) of + c -> c `seq` (jblock' (d - 1) q (c : cs)) + where + (q, r) = n `quotRem`{-Int`-} 10 +--} +-- +showsPositiveInteger integer = go (largeToSmallBaseLEList integer) + where + --really this would work with the highest power of ten < intSmallBase + go n cs = + case quotRem10 n of + (q,r) -> if isZeroInteger q then (showsDInt0through9 r cs) + else go q (showsDInt0through9 r cs) +--} +showsDInt0through9 :: DInt -> String -> String +showsDInt0through9 = showsPrec (pNat(0)) + +quotRem10 :: SmallBaseLEList -> (SmallBaseLEList, DInt) +quotRem10 = + case compare intSmallBase (dNat(10)) of + GT -> longDivideBySmall (dNat(10)) + LT -> let + small10 = largeToSmallBaseLEList ( (dNat(10)) !: [] ) + recipSmall10 = minimalReciprocal small10 + qrs10 = quotRemSmallSectioned_ small10 recipSmall10 + in \n -> + case qrs10 n of + (q, r) -> ( q, uncheckedToNum (smallToLargeBaseLEList r) ) + EQ -> \n -> case n of (d:ds) -> (ds, d); [] -> ([],(dNat(0))) + +--Read is just too horrible to implement ourselves +--By the way, this is inconsistent with GHC's instance Read Integer in +--trivial way that no one will care about, by virtue of GHC being slightly +--inconsistent with Haskell98. That however makes it sometimes fail +--with QuickCheck :-) +instance Class.Read Integer where + readsPrec _ = readSigned readDec + +--INTERESTING? same as hugs and haskell98 report: +indexError :: a +indexError = Error.error "Ix.index: Index out of range." + +instance Class.Ix Integer where + range (l,h) = enumFromTo l h + inRange (l,h) i = l <= i && i <= h + + index (l,h) i = if l <= i && i <= h + then intFromInteger (i - l) + else indexError + --INTERESTING? + --unsafeIndex (l,_h) i = intFromInteger (i - l) + + +instance Class.Bits Integer where + isSigned _ = True +--"The function bitSize is undefined for types that do not have a fixed +-- bitsize, like Integer." + (CInteger a) .&. (CInteger b) = mkInteger (tcAndInteger a b) + (CInteger a) .|. (CInteger b) = mkInteger (tcOrInteger a b) + xor (CInteger a) (CInteger b) = mkInteger (tcXOrInteger a b) + complement (CInteger a) = mkInteger (tcComplementInteger a) +--"For unbounded types like Integer, rotate is equivalent to shift." + shiftR (CInteger a) b = mkInteger (tcShiftRInteger a b) + shiftL (CInteger a) b = mkInteger (tcShiftLInteger a b) + rotateR (CInteger a) b = mkInteger (tcShiftRInteger a b) + rotateL (CInteger a) b = mkInteger (tcShiftLInteger a b) +--} + +-- ******************** Bits DInt => Bits HInteger ******************** +-- code ought to be cleaned up a lot here and commented. + +{- +zipWithDefaults :: (a -> b -> c) -> a -> b -> [a] -> [b] -> [c] +zipWithDefaults f defa defb = zp + where + zp (a:as) (b:bs) = f a b : zp as bs + zp [] [] = [] + zp [] bs = L.map (\b -> f defa b) bs + zp as [] = L.map (\a -> f a defb) as + +signed :: HInteger__ -> DInt +signed = if compareInteger i zeroInteger == LT + then (dNeg(1)) else (dNat(0)) + +zipWithSigns :: (DInt -> DInt -> DInt) -> HInteger__ -> HInteger__ + -> HInteger__ +zipWithSigns f a b = zipWithDefaults f (signed a) (signed b) a b +-} +signRep :: Bool -> DInt +signRep n = if n then (dNeg(1)) else (dNat(0)) +--tc = two's complement. For Bits, we assume DInt is two's complement +--and we act as if our Integer is an infinite two's complement bit-sequence. +--Could use +/- 1/0 instead of succ/id +--n = negative, f = final, m = modify, s = sign(Rep), +--(f = function), d = digit, (s = plural) +--Nat = natural = nonnegative +type Bin a = a -> a -> a +type Mon a = a -> a +{--prependMightBeNegBase :: DInt -> [DInt] -> [DInt] +prependMightBeNegBase d ds | negate intLargeBase >= d + = sees ("ph",d,ds) (intLargeBase + d) !: case ds of + [] -> negativeOneInteger + (d_:ds_) -> prependMightBeNegBase (pred d_) ds_ +prependMightBeNegBase d ds = prepend d ds--} +--negate(abs) it, subtract 1 (making sure to stay nat throughout), +-- flip all the bits, add 1 +--how will the (1)00000 bit pattern happen? +-- ((negate ((negate it)-1)) - 1) + 1 ==it+1? + +--tcn === become two's complement representation +--utcn === two's complement representation -> normal, dropping +-- most-significant zeroes that result +--etcn === inefficient, possibly only-negative, utcn that works more by the +-- definition of two's complement. It found a bug during development. +--ck (\(I ni) -> (\i -> i == mkInteger (utcn (tcn (case i of CInteger x->x)))) +-- (fromInteger (if ni >= 0 then complement ni else ni))) +--ck (\(I ni) -> (\i -> i == mkInteger (etcn (tcn (case i of CInteger x->x)))) +-- (fromInteger (if ni >= 0 then complement ni else ni))) +--etcn, +utcn :: [DInt] -> HInteger__ +tcn :: HInteger__ -> [DInt] +--etcn = (\x->case x of CInteger y ->y)P.. complement P.. P.foldr +-- (\d r-> d + 2*r) 0 P.. P.concatMap +-- (\i ->(P.map (\n -> (if testBit i n then 0 else 1)) +-- ([0..P.fromIntegral P.$intLargeExponentOfTwo-1]))) +tcn i = --P.concatMap (\i ->' ':(P.concatMap (\n -> (if (n+1) `mod` 88 == 0 + -- then (' ':) else id) P.$ if testBit i n then "1" else "0") + -- (P.reverse [0..intLargeExponentOfTwo-1]))) + -- P.$ P.reverse + (f i) + where + f [] = [] + f (d:ds) = d !: if (dNat(0)) <= d {-isZero (d {-.&. pred intLargeBase-})-} + then f ds else f_ ds + f_ = strictMap pred +-- f_ [] = [] +-- f_ (d:ds) = pred d !: if isZero (pred d .&. pred intLargeBase) +-- then f_ ds else f_ ds +utcn i = f i + where + f (d:ds) = let d_ = repairNegIntLargeBase d in + d_ `prepend` if (dNat(0)) <= d_ {-isZero d_-} + {-isZero (d .&. pred intLargeBase)-} then f ds else f_ ds + f [] = [] +-- f_ = strictMap succ + f_ (d:ds) = succ d `prepend` f_ ds + f_ [] = [] +-- f_ (d:ds) = if isZero (d .&. pred intLargeBase) +-- then (negate intLargeBase + 1) !: f_ ds +-- else succ d `prepend` f_ ds +-- f_ [] = [] +-- = let d_ = complement d +-- in if (dNeg(1)) == d_ then {-0-}negate intLargeBase : +-- case ds of (d__:ds__) -> +-- else +sr :: DInt -> DInt -> DInt +sr s d = if isZero s && (dNat(0)) <= d then (dNat(0)) else (dNeg(1)) +lowBits, highBits :: DInt +lowBits = pred intLargeBase +highBits = complement lowBits +--Don't ask me to give a good complete answer of why the code works: study it +--and trust QuickCheck. +tcBinOpInteger :: Bin DInt{-symmetric-} -> Bin Bool + -> Mon HInteger__ -> Mon HInteger__ + -> Bin HInteger__ +tcBinOpInteger op signOp endOpWithNat endOpWithNeg = \i1 i2 -> let + n1 = isNegativeInteger i1; n2 = isNegativeInteger i2; nf = n1 `signOp` n2 + --rs1 = signRep n1; rs2 = signRep n2; rsf = signRep nf +-- mask = sees ("mask",i1,i2,nf) P.$ if nf then high else (dNat(0)) +-- m = if nf then (high .|.) else (low .&.) +-- n x = if negate intLargeBase == x then (dNat(0)) else x + repair = if nf then (\d -> repairNegIntLargeBase (highBits .|. d)) + else (\d -> (lowBits .&. d)) +-- m1 = \d -> d + s1; m2 = \d -> d + s2; mf = \d -> d - sf +-- end n i = if n then endOpWithNeg i else endOpWithNat i--} + fi (d1:ds1) (d2:ds2) = prepend df dsf + where + df = repair (((d1 ) `op` (d2 )) ) + dsf = f ds1 ds2 + (signRep ((dNat(0)) > d1)) + (signRep ((dNat(0)) > d2)) + (signRep ((dNat(0)) > df)) + fi ds1@(_:_) [] = endOpWithNat ds1 + fi [] ds2@(_:_) = endOpWithNat ds2 + fi [] [] = [] + f (d1:ds1) (d2:ds2) s1 s2 sf = prepend df dsf + where + df = repair (((d1 + s1) `op` (d2 + s2)) - sf) + dsf = f ds1 ds2 (sr s1 d1) (sr s2 d2) (sr sf df) + f ds1@(_:_) [] s1 s2 sf = f1 ds1 s1 s2 sf + f [] ds2@(_:_) s1 s2 sf = f1 ds2 s2 s1 sf + f [] [] s1 s2 sf = f0 s1 s2 sf +-- f (d1:ds1) [] s1 s2 sf = prepend df dsf +-- where +-- df = ((d1 + s1) `op` ( s2)) - sf +-- dsf = f ds1 [] (sr s1 d1) ( s2 ) (sr sf df) +-- f [] [] s1 s2 sf = fromDInt df--prepend df dsf +-- where +-- df = (( s1) `op` ( s2)) - sf +-- --dsf = []--f [] [] ( s1 ) ( s2 ) (sr sf df) + --asymptotic-efficiency-adding optimization: + f1 i s1 s2 sf | s1 == sf = if isZero s2 then endOpWithNat i + else endOpWithNeg i + f1 [] s1 s2 sf = f0 s1 s2 sf + f1 (d1:ds1) s1 s2 sf = prepend df dsf + where + df = repair (((d1 + s1) `op` ( s2)) - sf) + dsf = f1 ds1 (sr s1 d1) ( s2 ) (sr sf df) + f0 s1 s2 sf = fromDInt df--prepend df dsf + where + df = repair ((( s1) `op` ( s2)) - sf) + --dsf = []--f [] [] ( s1 ) ( s2 ) (sr sf df) +{-- + f1 i s sf = if s == sf then i else + case i of + [] -> (sf - s) !: [] + (d:ds) -> prepend df dsf + where + df = d + s - sf + dsf = f1 ds (sr s d) (sr sf df)--} +{-- f21 (d1:ds1) (d2:ds2) sf = prepend df + (f2_ (isZero d1) (isZero d2) (isZero df)) + df = d1 `op` d2 + f False False False = f00 ds1 ds2 + f False True = f1 ds2 ds1 + f True False = f1 ds1 ds2 + f True True = f2 ds1 ds2 + f1 + f0 + f (d1:ds1) (d2:ds2) s1 s2 sf = sees ("f",(d1,ds1),(d2,ds2)) P.$ + prepend (mf (m1 d1 `op` m2 d2)) (f (if ds1 ds2) + f [] [] = sees "f[]" [] + f [] ds2 = sees ("f2",ds2) P.$ end n1 ds2 + f ds1 [] = sees ("f1",ds1) P.$ end n2 ds1 + f_ (d1:ds1) (d2:ds2) = sees "f_1" P.$ + prependMightBeNegBase (d1 `op` d2) (f ds1 ds2) + f_ [] [] = [] + f_ [] ds2 = endOpWithNat ds2 + f_ ds1 [] = endOpWithNat ds1--} + in fi i1 i2 --(dNat(0)) (dNat(0)) (dNat(0)) +tcXOrInteger, tcOrInteger, tcAndInteger :: Bin HInteger__ +tcXOrInteger = tcBinOpInteger (xor) (/=) (id) (tcComplementInteger) +tcOrInteger = tcBinOpInteger (.|.) (||) (id) (const []) +tcAndInteger = tcBinOpInteger (.&.) (&&) (const []) (id) + +-- complement i === -1 - i +tcComplementInteger :: HInteger__ -> HInteger__ +tcComplementInteger i = predInteger (negateInteger i) + +tcShiftRInteger, tcShiftLInteger :: HInteger__ -> PInt -> HInteger__ + +tcShiftRInteger i r = (utcn (tcShiftR_TC (tcn i) r)) +tcShiftLInteger i l = (utcn (tcShiftL_TC (tcn i) l)) + + +--we would need fromDInt/prepend ... that treated -1 as badly as zero +--when most-significant, for these, if we don't just let utcn do that +tcShiftR_TC, tcShiftL_TC :: [DInt] -> PInt -> [DInt] + +tcShiftR_TC (d:ds) r | r >= intLargeExponentOfTwo + = case ds of + [] -> fromDInt (signRep ((dNat(0)) > d)) + (_:_) -> tcShiftR_TC ds (r - intLargeExponentOfTwo) +tcShiftR_TC [] _r = [] +tcShiftR_TC i@(_:_) r = f i + where + l = intLargeExponentOfTwo - r + ourLowBits = pred (bit l) + --higherBits = complement ourLowBits + --don't overflow DInt even temporarily and even when using Bits + --operations :) my testing int complains and there's no need to + --higherBits = shiftR highBits l + onlyLowerBits = pred (bit r) + lowerBits = highBits .|. ourLowBits + f (d:[]) = {-fromDInt-} (shiftR d r) !: fromDInt (signRep ((dNat(0)) > d)) + f (d:(ds@(dAbove:_))) = df !: f ds --prepend df dsf + where + df = {-(highBits .&. dAbove) .|.-} (lowerBits .&. shiftR d r) + .|. (shiftL (onlyLowerBits .&. dAbove) l) + --(higherBits .&. shiftL dAbove l) +-- dsf = f ds + +tcShiftL_TC [] _l = [] +tcShiftL_TC i l | l >= intLargeExponentOfTwo + = (dNat(0)) !: tcShiftL_TC i (l - intLargeExponentOfTwo) +tcShiftL_TC i@(d1:_) l = dFirst !: f i--increase decrease left right + where + dFirst = (highBits .&. d1) .|. shiftL (onlyLowerBits .&. d1) l + r = intLargeExponentOfTwo - l + ourLowBits = pred (bit l) + --higherBits = complement ourLowBits + --don't overflow DInt even temporarily and even when using Bits + --operations :) my testing int complains and there's no need to + --higherBits = shiftR highBits l + onlyLowerBits = pred (bit r) + lowerBits = highBits .|. ourLowBits + f (dBelow:[]) = {-fromDInt-} (shiftR dBelow r) !: [] + f (dBelow:(ds@(d:_))) = df !: f ds --prepend df dsf + where + df = (highBits .&. d) .|. (lowerBits .&. shiftR dBelow r) + .|. (shiftL (onlyLowerBits .&. d) l) + --(higherBits .&. shiftL d l) +-- dsf = f ds +{- + + + + + + foldr (\d (bitwiseDAbove,result) -> + let bitwiseD = mi d in + ( bitwiseD + , prepend + (mf ( + (nonHighMask .&. shiftR r bitwiseD) + `xor` --or .|. + (highMask .&. shiftL l bitwiseDAbove) + )) + result + ) + ) + (wrong?s,[]) + +--optimize small cases: +shiftRInteger [] _ = [] +shiftRInteger (d:[]) b = fromDInt (shiftR d b) +shiftRInteger i b = let + n = isNegativeInteger i --shifting preserves sign + s = signRep n + mi = \d -> d + s1; mf = \d -> d - s1 + case b `quotRem` intLargeExponentOfTwo of + (q,r) -> let + l = intLargeExponentOfTwo - r + highRealBits = (pred intLargeBase) `xor` (pred (shiftL (dNat(1)) r)) + otherBits = complement highRealBits + i_ = L.drop q i + --we don't care where the high bits indicating sign + --come from; they're the same everywhere... except from + --shiftL + foldr (\d (bitwiseDAbove,result) -> + let bitwiseD = mi d in + ( bitwiseD + , prepend + (mf ( + (nonHighMask .&. shiftR r bitwiseD) + `xor` --or .|. + (highMask .&. shiftL l bitwiseDAbove) + )) + result + ) + ) + (wrong?s,[]) + [] = [] + (d:[]) = (bitwiseD, fromDInt (shiftR r bitwiseD + (d:ds) = case r ds of (bitwiseDAbove,result) -> + (nonHighMask .&. shiftR r (mi )) `xor` (highMask .&. shiftL l (mi )) +-} + +-- -} + +main = let large :: [Integer] + large = P.map (\n -> 2 P.^ n) [1..100 :: Integer] + in Print.print large diff --git a/tests/3_shootout/BinaryTrees.args b/tests/3_shootout/BinaryTrees.args new file mode 100644 --- /dev/null +++ b/tests/3_shootout/BinaryTrees.args @@ -0,0 +1,1 @@ +12 diff --git a/tests/3_shootout/BinaryTrees.expected.stdout b/tests/3_shootout/BinaryTrees.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/3_shootout/BinaryTrees.expected.stdout @@ -0,0 +1,7 @@ +stretch tree of depth 13 check: -1 +8192 trees of depth 4 check: -8192 +2048 trees of depth 6 check: -2048 +512 trees of depth 8 check: -512 +128 trees of depth 10 check: -128 +32 trees of depth 12 check: -32 +long lived tree of depth 12 check: -1 diff --git a/tests/3_shootout/BinaryTrees.hs b/tests/3_shootout/BinaryTrees.hs new file mode 100644 --- /dev/null +++ b/tests/3_shootout/BinaryTrees.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -fglasgow-exts -O2 -optc-O3 -funbox-strict-fields #-} +-- The Great Computer Language Shootout +-- http://shootout.alioth.debian.org/ +-- Simon Marlow +-- Shortened by Don Stewart +-- De-optimized by Isaac Gouy + +import System.Environment; import Text.Printf; import Control.Monad + + +data Tree = Nil | Node !Int Tree Tree + +min' = 4 :: Int + +main = do max' <- getArgs >>= return . max (min'+2) . read . head + printf "stretch tree of depth %d\t check: %d\n" (max'+1) (itemCheck $ make 0 (max'+1)) + depthLoop min' max' + printf "long lived tree of depth %d\t check: %d\n" max' (itemCheck $ make 0 max') + +depthLoop :: Int -> Int -> IO () +depthLoop d m = when (d <= m) $ do + printf "%d\t trees of depth %d\t check: %d\n" (2*n) d (sumLoop n d 0) + depthLoop (d+2) m + where n = 2^(m - d + min') + +sumLoop 0 d acc = acc :: Int +sumLoop k d acc = c `seq` sumLoop (k-1) d (acc + c + c') + where (c,c') = (itemCheck (make k d), itemCheck (make (-1*k) d)) + +-- make i (0::Int) = i `seq` Nil +make :: Int -> Int -> Tree +make i 0 = Node i Nil Nil +make i d = {-trace ("make: " ++ show (i,d)) $ -} Node i (make ((2*i)-1) (d-1)) (make (2*i) (d-1)) + +itemCheck Nil = 0 +itemCheck (Node x l r) = x + itemCheck l - itemCheck r diff --git a/tests/3_shootout/Mandelbrot.args b/tests/3_shootout/Mandelbrot.args new file mode 100644 --- /dev/null +++ b/tests/3_shootout/Mandelbrot.args @@ -0,0 +1,1 @@ +1000 diff --git a/tests/3_shootout/Mandelbrot.expected.stdout b/tests/3_shootout/Mandelbrot.expected.stdout new file mode 100644 Binary files /dev/null and b/tests/3_shootout/Mandelbrot.expected.stdout differ diff --git a/tests/3_shootout/Mandelbrot.hs b/tests/3_shootout/Mandelbrot.hs new file mode 100644 --- /dev/null +++ b/tests/3_shootout/Mandelbrot.hs @@ -0,0 +1,25 @@ +-- The Great Computer Language Shootout +-- http://shootout.alioth.debian.org/ +-- Based on the SML version, written by Matthias Blume. +-- Implemented in Haskell by Don Stewart +-- +import System; import Data.Bits; import Data.Word; import Text.Printf; import Data.Char + +main = do (w::Word32) <- getArgs >>= readIO . head + printf "P4\n%d %d\n" (fromIntegral w::Int) (fromIntegral w::Int) >> yl 0 w w + +yl y h w = if y < h then xl 0 y 0 8 h w else return () + +xl x y b n h w + | x == w = putChar (chr $ b `shiftL` n) >> yl (y+1) h w + | otherwise = do + (b',n') <- if n == 0 then putChar (chr b) >> return (0,8) else return (b,n) + xl (x+1) y (b'+b'+ fromEnum (p x y w h)) (n'-1) h w + +p (x::Word32) y w h = lp 0.0 0.0 50 (f x * 2.0 / f w - 1.5) (f y * 2.0 / f h - 1.0) + where f = fromIntegral + +lp r i k cr ci | r2 + i2 > (4.0 :: Double) = 0 :: Word32 + | k == (0 :: Word32) = 1 + | otherwise = lp (r2-i2+cr) ((r+r)*i+ci) (k-1) cr ci + where r2 = r*r ; i2 = i*i diff --git a/tests/3_shootout/Mandelbrot.mustfail b/tests/3_shootout/Mandelbrot.mustfail new file mode 100644 --- /dev/null +++ b/tests/3_shootout/Mandelbrot.mustfail diff --git a/tests/3_shootout/PartialSums.args b/tests/3_shootout/PartialSums.args new file mode 100644 --- /dev/null +++ b/tests/3_shootout/PartialSums.args @@ -0,0 +1,1 @@ +250 diff --git a/tests/3_shootout/PartialSums.expected.stdout b/tests/3_shootout/PartialSums.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/3_shootout/PartialSums.expected.stdout @@ -0,0 +1,9 @@ +3.000000000 (2/3)^k +30.194034329 k^-0.5 +0.996015936 1/k(k+1) +4.806858125 Flint Hills +42.991485930 Cookson Hills +6.100675249 Harmonic +1.640942056 Riemann Zeta +0.691151181 Alternating Harmonic +0.784398167 Gregory diff --git a/tests/3_shootout/PartialSums.hs b/tests/3_shootout/PartialSums.hs new file mode 100644 --- /dev/null +++ b/tests/3_shootout/PartialSums.hs @@ -0,0 +1,31 @@ +-- +-- The Great Computer Language Shootout +-- http://shootout.alioth.debian.org/ +-- +-- Haskell version of Isaac Gouy's Clean version, translated by Don Stewart +-- + +import System; import Numeric + +main = do n <- getArgs >>= readIO . head + let sums = loop (1::Int) n 1 0 0 0 0 0 0 0 0 0 + fn (s,t) = putStrLn $ (showFFloat (Just 9) s []) ++ "\t" ++ t + mapM_ (fn :: (Double, String) -> IO ()) (zip sums names) + +names = ["(2/3)^k", "k^-0.5", "1/k(k+1)", "Flint Hills", "Cookson Hills" + , "Harmonic", "Riemann Zeta", "Alternating Harmonic", "Gregory"] + +loop i n alt a1 a2 a3 a4 a5 a6 a7 a8 a9 + | i !n !alt !a1 !a2 !a3 !a4 !a5 !a6 !a7 !a8 !a9 !False = undefined -- strict + | k > n = [ a1, a2, a3, a4, a5, a6, a7, a8, a9 ] + | otherwise = loop (i+1) n (-alt) + (a1 + (2/3) ** (k-1)) + (a2 + 1 / sqrt k) + (a3 + 1 / (k * (k + 1))) + (a4 + 1 / (k3 * sk * sk)) + (a5 + 1 / (k3 * ck * ck)) + (a6 + dk) + (a7 + 1 / k2) + (a8 + alt * dk) + (a9 + alt / (2 * k - 1)) + where k3 = k2*k; k2 = k*k; dk = 1/k; k = fromIntegral i; sk = sin k; ck = cos k; x!y = x`seq`y diff --git a/tests/3_shootout/PartialSums.mustfail b/tests/3_shootout/PartialSums.mustfail new file mode 100644 --- /dev/null +++ b/tests/3_shootout/PartialSums.mustfail diff --git a/tests/3_shootout/SumFile.expected.stdout b/tests/3_shootout/SumFile.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/3_shootout/SumFile.expected.stdout @@ -0,0 +1,1 @@ +12 diff --git a/tests/3_shootout/SumFile.hs b/tests/3_shootout/SumFile.hs new file mode 100644 --- /dev/null +++ b/tests/3_shootout/SumFile.hs @@ -0,0 +1,22 @@ +-- +-- The Computer Language Shootout +-- http://shootout.alioth.debian.org/ +-- +-- compile with : ghc fastest.hs -o fastest +-- +-- contributed by Greg Buchholz +-- Modified by Mirko Rahn, Don Stewart, Chris Kuklewicz and Lemmih +-- +import Data.Char + +main = print . new 0 =<< getContents + +new i [] = i +new i ('-':xs) = neg 0 xs + where neg n ('\n':xs) = new (i - n) xs + neg n (x :xs) = neg (parse x + (10 * n)) xs +new i (x:xs) = pos (parse x) xs + where pos n ('\n':xs) = new (i + n) xs + pos n (x :xs) = pos (parse x + (10 * n)) xs + +parse c = ord c - ord '0' diff --git a/tests/3_shootout/SumFile.stdin b/tests/3_shootout/SumFile.stdin new file mode 100644 --- /dev/null +++ b/tests/3_shootout/SumFile.stdin @@ -0,0 +1,3 @@ +3 +4 +5 diff --git a/tests/9_nofib/digits-of-e1.expected.stdout b/tests/9_nofib/digits-of-e1.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/9_nofib/digits-of-e1.expected.stdout @@ -0,0 +1,1 @@ +[2,7,1,8,2,8,1,8,2,8,4,5,9,0,4,5,2,3,5,3,6,0,2,8,7,4,7,1,3,5,2,6,6,2,4,9,7,7,5,7,2,4,7,0,9,3,6,9,9,9,5,9,5,7,4,9,6,6,9,6,7,6,2,7,7,2,4,0,7,6,6,3,0,3,5,3,5,4,7,5,9,4,5,7,1,3,8,2,1,7,8,5,2,5,1,6,6,4,2,7] diff --git a/tests/9_nofib/digits-of-e1.hs b/tests/9_nofib/digits-of-e1.hs new file mode 100644 --- /dev/null +++ b/tests/9_nofib/digits-of-e1.hs @@ -0,0 +1,51 @@ +{- +Compute the digits of "e" using continued fractions. +Original program due to Dale Thurston, Aug 2001 +-} + +import System.Environment + +type ContFrac = [Integer] + +{- +Compute the decimal representation of e progressively. + +A continued fraction expansion for e is + +[2,1,2,1,1,4,1,1,6,1,...] +-} + +eContFrac :: ContFrac +eContFrac = 2:aux 2 where aux n = 1:n:1:aux (n+2) + +{- +We need a general function that applies an arbitrary linear fractional +transformation to a legal continued fraction, represented as a list of +positive integers. The complicated guard is to see if we can output a +digit regardless of what the input is; i.e., to see if the interval +[1,infinity) is mapped into [k,k+1) for some k. +-} + +-- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction +ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac +-- Output a digit if we can +ratTrans (a,b,c,d) xs | + ((signum c == signum d) || (abs c < abs d)) && -- No pole in range + (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b -- Next digit is determined + = q:ratTrans (c,d,a-q*c,b-q*d) xs + where q = b `div` d +ratTrans (a,b,c,d) (x:xs) = ratTrans (b,a+x*b,d,c+x*d) xs + +-- Finally, we convert a continued fraction to digits by repeatedly multiplying by 10. + +toDigits :: ContFrac -> [Integer] +toDigits (x:xs) = x:toDigits (ratTrans (10,0,0,1) xs) + +e :: [Integer] +e = toDigits eContFrac + +main = do + [digits] <- getArgs + print (take (read digits) e) + + diff --git a/tests/9_nofib/spectral/calendar/Calendar.args b/tests/9_nofib/spectral/calendar/Calendar.args new file mode 100644 --- /dev/null +++ b/tests/9_nofib/spectral/calendar/Calendar.args @@ -0,0 +1,1 @@ +2034 diff --git a/tests/9_nofib/spectral/calendar/Calendar.expected.stdout b/tests/9_nofib/spectral/calendar/Calendar.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/9_nofib/spectral/calendar/Calendar.expected.stdout @@ -0,0 +1,38 @@ + 2034 + + January February March + Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa + 1 2 3 4 5 6 7 1 2 3 4 1 2 3 4 + 8 9 10 11 12 13 14 5 6 7 8 9 10 11 5 6 7 8 9 10 11 + 15 16 17 18 19 20 21 12 13 14 15 16 17 18 12 13 14 15 16 17 18 + 22 23 24 25 26 27 28 19 20 21 22 23 24 25 19 20 21 22 23 24 25 + 29 30 31 26 27 28 26 27 28 29 30 31 + + + April May June + Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa + 1 1 2 3 4 5 6 1 2 3 + 2 3 4 5 6 7 8 7 8 9 10 11 12 13 4 5 6 7 8 9 10 + 9 10 11 12 13 14 15 14 15 16 17 18 19 20 11 12 13 14 15 16 17 + 16 17 18 19 20 21 22 21 22 23 24 25 26 27 18 19 20 21 22 23 24 + 23 24 25 26 27 28 29 28 29 30 31 25 26 27 28 29 30 + 30 + + July August September + Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa + 1 1 2 3 4 5 1 2 + 2 3 4 5 6 7 8 6 7 8 9 10 11 12 3 4 5 6 7 8 9 + 9 10 11 12 13 14 15 13 14 15 16 17 18 19 10 11 12 13 14 15 16 + 16 17 18 19 20 21 22 20 21 22 23 24 25 26 17 18 19 20 21 22 23 + 23 24 25 26 27 28 29 27 28 29 30 31 24 25 26 27 28 29 30 + 30 31 + + October November December + Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa Su Mo Tu We Th Fr Sa + 1 2 3 4 5 6 7 1 2 3 4 1 2 + 8 9 10 11 12 13 14 5 6 7 8 9 10 11 3 4 5 6 7 8 9 + 15 16 17 18 19 20 21 12 13 14 15 16 17 18 10 11 12 13 14 15 16 + 22 23 24 25 26 27 28 19 20 21 22 23 24 25 17 18 19 20 21 22 23 + 29 30 31 26 27 28 29 30 24 25 26 27 28 29 30 + 31 + diff --git a/tests/9_nofib/spectral/calendar/Calendar.hs b/tests/9_nofib/spectral/calendar/Calendar.hs new file mode 100644 --- /dev/null +++ b/tests/9_nofib/spectral/calendar/Calendar.hs @@ -0,0 +1,136 @@ +-- This is a modification of the calendar program described in section 4.5 +-- of Bird and Wadler's ``Introduction to functional programming'', with +-- two ways of printing the calendar ... as in B+W, or like UNIX `cal': + +import System.IO -- 1.3 +import System.Environment -- 1.3 +import Data.List -- 1.3 +import Data.Char -- 1.3 + + +-- Picture handling: + +infixr 5 `above`, `beside` + +type Picture = [[Char]] + +height, width :: Picture -> Int +height p = length p +width p = length (head p) + +above, beside :: Picture -> Picture -> Picture +above = (++) +beside = zipWith (++) + +stack, spread :: [Picture] -> Picture +stack = foldr1 above +spread = foldr1 beside + +empty :: (Int,Int) -> Picture +empty (h,w) = copy h (copy w ' ') + +block, blockT :: Int -> [Picture] -> Picture +block n = stack . map spread . groop n +blockT n = spread . map stack . groop n + +groop :: Int -> [a] -> [[a]] +groop n [] = [] +groop n xs = take n xs : groop n (drop n xs) + +lframe :: (Int,Int) -> Picture -> Picture +lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n) + where h = height p + w = width p + +-- Information about the months in a year: + +monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31] + where feb | leap year = 29 + | otherwise = 28 + +leap year = if year`mod`100 == 0 then year`mod`400 == 0 + else year`mod`4 == 0 + +monthNames = ["January","February","March","April", + "May","June","July","August", + "September","October","November","December"] + +jan1st year = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7 + where last = year - 1 + +firstDays year = take 12 + (map (`mod`7) + (scanl (+) (jan1st year) (monthLengths year))) + +-- Producing the information necessary for one month: + +dates fd ml = map (date ml) [1-fd..42-fd] + where date ml d | d<1 || ml String +calendar = unlines . block 3 . map picture . months + where picture (mn,yr,fd,ml) = title mn yr `above` table fd ml + title mn yr = lframe (2,25) [mn ++ " " ++ show yr] + table fd ml = lframe (8,25) + (daynames `beside` entries fd ml) + daynames = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"] + entries fd ml = blockT 7 (dates fd ml) + months year = zip4 monthNames + (copy 12 year) + (firstDays year) + (monthLengths year) + +-- In a format somewhat closer to UNIX cal: + +cal year = unlines (banner year `above` body year) + where banner yr = [cjustify 75 (show yr)] `above` empty (1,75) + body = block 3 . map (pad . pic) . months + pic (mn,fd,ml) = title mn `above` table fd ml + pad p = (side`beside`p`beside`side)`above`end + side = empty (8,2) + end = empty (1,25) + title mn = [cjustify 21 mn] + table fd ml = daynames `above` entries fd ml + daynames = [" Su Mo Tu We Th Fr Sa"] + entries fd ml = block 7 (dates fd ml) + months year = zip3 monthNames + (firstDays year) + (monthLengths year) + +-- For a standalone calendar program: + +main = do + strs <- getArgs + case strs of [year] -> calFor year + _ -> fail ("Usage: cal year\n") + + +calFor year | illFormed = fail ("Bad argument") + | otherwise = putStr (cal yr) + where illFormed = null ds || not (null rs) + (ds,rs) = span isDigit year + yr = atoi ds + atoi s = foldl (\a d -> 10*a+d) 0 (map toDigit s) + toDigit d = fromEnum d - fromEnum '0' + + +-- End of calendar program + +-- tacked on by partain +copy :: Int -> a -> [a] +copy n x = take n (repeat x) + +cjustify, ljustify, rjustify :: Int -> String -> String + +cjustify n s = space halfm ++ s ++ space (m - halfm) + where m = n - length s + halfm = m `div` 2 +ljustify n s = s ++ space (n - length s) +rjustify n s = space (n - length s) ++ s + +space :: Int -> String +space n = copy n ' ' +-- end of tack diff --git a/tests/9_nofib/spectral/primes/Primes.expected.stdout b/tests/9_nofib/spectral/primes/Primes.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/9_nofib/spectral/primes/Primes.expected.stdout @@ -0,0 +1,1 @@ +1229 diff --git a/tests/9_nofib/spectral/primes/Primes.hs b/tests/9_nofib/spectral/primes/Primes.hs new file mode 100644 --- /dev/null +++ b/tests/9_nofib/spectral/primes/Primes.hs @@ -0,0 +1,24 @@ + +import System.IO + +suCC :: Int -> Int +suCC x = x + 1 + +isdivs :: Int -> Int -> Bool +isdivs n x = mod x n /= 0 + +--the_filter :: [Int] -> [Int] +--the_filter (n:ns) = filter (isdivs n) ns + +the_filter :: [Int] -> [Int] +the_filter (n:ns) = f ns where + f [] = [] + f (x:ns) | isdivs n x = (x:f ns) + f (_:ns) = f ns + +primes :: [Int] +primes = map head (iterate the_filter (iterate suCC 2)) + +main = do + --[arg] <- getArgs + print $ primes !! 200 -- (read arg) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,135 @@ +module UnitTests + ( unitTests + ) where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit + +import Test.HUnit +import System.FilePath +import System.Directory +import System.Process +import Control.Monad +import Control.Monad.Error +import qualified Data.ByteString.Char8 as B +import Control.Concurrent +import Control.Exception +import System.Exit +import System.IO + +unitTests = [ testGroup "io" basicTests + , testGroup "language" languageTests + , testGroup "shootout" shootoutTests + , testGroup "nofib" nofibTests + , testGroup "bugs" bugsTests + ] + + +basicTests + = [ lhcTest dir name | name <- tests ] + where dir = ["tests","1_io","basic"] + tests = [ "Args" + , "HelloWorld" + , "enum" + , "fastest_fib" + , "IORef" + , "Echo" ] + +languageTests + = [ lhcTest dir name | name <- tests ] + where dir = ["tests","2_language"] + tests = [ "Bounds" + , "CPP" + , "EnumEnum" + , "IntEnum" + , "IrrefutableLambda" + , "KindInference" + , "Kleisli" + , "PureInteger" + , "Laziness" + , "Defaulting" + , "NoMonomorphism" ] + +shootoutTests + = [ lhcTest dir name | name <- tests ] + where dir = ["tests", "3_shootout"] + tests = [ "BinaryTrees" + , "Mandelbrot" + , "SumFile"] + +nofibTests + = [ lhcTest dir name | name <- tests ] ++ + [ lhcTest (dir ++ ["spectral","calendar"]) "Calendar" ] ++ + [ lhcTest (dir ++ ["spectral","primes"]) "Primes" ] + where dir = ["tests", "9_nofib"] + tests = [ "digits-of-e1" ] + + +bugsTests + = [ lhcTest dir name | name <- tests ] + where dir = ["tests", "bugs"] + tests = ["ImportZeal" + ,"Parsing1" + ,"RayT" + ,"Qualify1" + ,"Recursive2" + ,"UnpackedPoly" + ,"Exceptions1"] + + + + + + + +------------------------------------------------------------------------------ +-- Framework code + +lhcTest path name + = testCase name $ + do let testFile = joinPath path name <.> "hs" + exist <- doesFileExist testFile + unless exist $ fail "Cannot find test file." + removeFile (dropExtension testFile) `mplus` return () + args <- B.readFile (replaceExtension testFile "args") `mplus` return B.empty + input <- B.readFile (replaceExtension testFile "stdin") `mplus` return B.empty + expectedOutput <- B.readFile (replaceExtension testFile "expected.stdout") `mplus` return B.empty + mustfail <- doesFileExist (replaceExtension testFile "mustfail") + handleFailures mustfail $ do + execProcess "lhc" ["--make", "-O2", "-c", "-fforce-recomp", testFile] B.empty + execProcess "lhc" ["benchmark", replaceExtension testFile "hcr"] B.empty + (_,output,_) <- execProcess (dropExtension testFile) (words $ B.unpack args) input + let failed = output /= expectedOutput + when failed $ + fail $ unlines [ "Program result doesn't match expected output." + , "Program output:" + , take 100 (show (B.unpack output)) + , "Expected output:" + , take 100 (show (B.unpack expectedOutput)) ] + +handleFailures False cmd = cmd +handleFailures True cmd + = do e <- try cmd :: IO (Either SomeException ()) + case e of + Right () -> fail $ "Program succeded unexpectantly." + Left e -> return () + + +execProcess :: FilePath -> [String] -> B.ByteString -> IO (ExitCode, B.ByteString, B.ByteString) +execProcess cmd args input = do + (inh, outh, errh, pid) <- runInteractiveProcess cmd args Nothing Nothing + handle (\e -> do terminateProcess pid + throw (e::SomeException)) $ do + outVar <- newEmptyMVar + forkIO $ B.hGetContents outh >>= putMVar outVar + errVar <- newEmptyMVar + forkIO $ B.hGetContents errh >>= putMVar errVar + + when (not (B.null input)) $ do B.hPutStr inh input >> hFlush inh + hClose inh + + out <- takeMVar outVar + err <- takeMVar errVar + ret <- waitForProcess pid + return (ret, out, err) + diff --git a/tests/bugs/Exceptions1.expected.stdout b/tests/bugs/Exceptions1.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/bugs/Exceptions1.expected.stdout @@ -0,0 +1,1 @@ + diff --git a/tests/bugs/Exceptions1.hs b/tests/bugs/Exceptions1.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/Exceptions1.hs @@ -0,0 +1,7 @@ +module Main where + +import Control.Exception +import Prelude hiding (catch) + +main :: IO () +main = (error "Catch me!" `seq` return ()) `catch` \_ -> return () diff --git a/tests/bugs/Exceptions1.mustfail b/tests/bugs/Exceptions1.mustfail new file mode 100644 --- /dev/null +++ b/tests/bugs/Exceptions1.mustfail diff --git a/tests/bugs/ImportZeal.expected.stdout b/tests/bugs/ImportZeal.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/bugs/ImportZeal.expected.stdout @@ -0,0 +1,1 @@ +{True->False;False->True} diff --git a/tests/bugs/ImportZeal.hs b/tests/bugs/ImportZeal.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/ImportZeal.hs @@ -0,0 +1,437 @@ + +--------------------------------------------------------------------- +-- SmallCheck: another lightweight testing library. +-- Colin Runciman, August 2006 +-- Version 0.4, 23 May 2008 +-- +-- After QuickCheck, by Koen Claessen and John Hughes (2000-2004). +--------------------------------------------------------------------- + +{- +module Test.SmallCheck ( + smallCheck, smallCheckI, depthCheck, test, + Property, Testable, + forAll, forAllElem, + exists, existsDeeperBy, thereExists, thereExistsElem, + exists1, exists1DeeperBy, thereExists1, thereExists1Elem, + (==>), + Series, Serial(..), + (\/), (><), two, three, four, + cons0, cons1, cons2, cons3, cons4, + alts0, alts1, alts2, alts3, alts4, + N(..), Nat, Natural, + depth, inc, dec + ) where +-} + +import Data.List (intersperse) +import Control.Monad (when) +import System.IO (stdout, hFlush) +import Foreign (unsafePerformIO) -- used only for Testable (IO a) + +------------------ ----------------- + +-- Series arguments should be interpreted as a depth bound (>=0) +-- Series results should have finite length + +type Series a = Int -> [a] + +-- sum +infixr 7 \/ +(\/) :: Series a -> Series a -> Series a +s1 \/ s2 = \d -> s1 d ++ s2 d + +-- product +infixr 8 >< +(><) :: Series a -> Series b -> Series (a,b) +s1 >< s2 = \d -> [(x,y) | x <- s1 d, y <- s2 d] + +------------------- ------------------ + +-- enumerated data values should be finite and fully defined +-- enumerated functional values should be total and strict + +-- bounds: +-- for data values, the depth of nested constructor applications +-- for functional values, both the depth of nested case analysis +-- and the depth of results + +class Serial a where + series :: Series a + coseries :: Series b -> Series (a->b) + +instance Serial () where + series _ = [()] + coseries rs d = [ \() -> b + | b <- rs d ] + +instance Serial Int where + series d = [(-d)..d] + coseries rs d = [ \i -> if i > 0 then f (N (i - 1)) + else if i < 0 then g (N (abs i - 1)) + else z + | z <- alts0 rs d, f <- alts1 rs d, g <- alts1 rs d ] + +instance Serial Integer where + series d = [ toInteger (i :: Int) + | i <- series d ] + coseries rs d = [ f . (fromInteger :: Integer->Int) + | f <- coseries rs d ] + +newtype N a = N a + deriving (Eq, Ord) + +instance Show a => Show (N a) where + show (N i) = show i + +instance (Integral a, Serial a) => Serial (N a) where + series d = map N [0..d'] + where + d' = fromInteger (toInteger d) + coseries rs d = [ \(N i) -> if i > 0 then f (N (i - 1)) + else z + | z <- alts0 rs d, f <- alts1 rs d ] + +type Nat = N Int +type Natural = N Integer + +instance Serial Float where + series d = [ encodeFloat sig exp + | (sig,exp) <- series d, + odd sig || sig==0 && exp==0 ] + coseries rs d = [ f . decodeFloat + | f <- coseries rs d ] + +instance Serial Double where + series d = [ frac (x :: Float) + | x <- series d ] + coseries rs d = [ f . (frac :: Double->Float) + | f <- coseries rs d ] + +frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b +frac = fromRational . toRational + +instance Serial Char where + series d = take (d+1) ['a'..'z'] + coseries rs d = [ \c -> f (N (fromEnum c - fromEnum 'a')) + | f <- coseries rs d ] + +instance (Serial a, Serial b) => + Serial (a,b) where + series = series >< series + coseries rs = map uncurry . (coseries $ coseries rs) + +instance (Serial a, Serial b, Serial c) => + Serial (a,b,c) where + series = \d -> [(a,b,c) | (a,(b,c)) <- series d] + coseries rs = map uncurry3 . (coseries $ coseries $ coseries rs) + +instance (Serial a, Serial b, Serial c, Serial d) => + Serial (a,b,c,d) where + series = \d -> [(a,b,c,d) | (a,(b,(c,d))) <- series d] + coseries rs = map uncurry4 . (coseries $ coseries $ coseries $ coseries rs) + +uncurry3 :: (a->b->c->d) -> ((a,b,c)->d) +uncurry3 f (x,y,z) = f x y z + +uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e) +uncurry4 f (w,x,y,z) = f w x y z + +two :: Series a -> Series (a,a) +two s = s >< s + +three :: Series a -> Series (a,a,a) +three s = \d -> [(x,y,z) | (x,(y,z)) <- (s >< s >< s) d] + +four :: Series a -> Series (a,a,a,a) +four s = \d -> [(w,x,y,z) | (w,(x,(y,z))) <- (s >< s >< s >< s) d] + +cons0 :: + a -> Series a +cons0 c _ = [c] + +cons1 :: Serial a => + (a->b) -> Series b +cons1 c d = [c z | d > 0, z <- series (d-1)] + +cons2 :: (Serial a, Serial b) => + (a->b->c) -> Series c +cons2 c d = [c y z | d > 0, (y,z) <- series (d-1)] + +cons3 :: (Serial a, Serial b, Serial c) => + (a->b->c->d) -> Series d +cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)] + +cons4 :: (Serial a, Serial b, Serial c, Serial d) => + (a->b->c->d->e) -> Series e +cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)] + +alts0 :: Series a -> + Series a +alts0 as d = as d + +alts1 :: Serial a => + Series b -> Series (a->b) +alts1 bs d = if d > 0 then coseries bs (dec d) + else [\_ -> x | x <- bs d] + +alts2 :: (Serial a, Serial b) => + Series c -> Series (a->b->c) +alts2 cs d = if d > 0 then coseries (coseries cs) (dec d) + else [\_ _ -> x | x <- cs d] + +alts3 :: (Serial a, Serial b, Serial c) => + Series d -> Series (a->b->c->d) +alts3 ds d = if d > 0 then coseries (coseries (coseries ds)) (dec d) + else [\_ _ _ -> x | x <- ds d] + +alts4 :: (Serial a, Serial b, Serial c, Serial d) => + Series e -> Series (a->b->c->d->e) +alts4 es d = if d > 0 then coseries (coseries (coseries (coseries es))) (dec d) + else [\_ _ _ _ -> x | x <- es d] + +instance Serial Bool where + series = cons0 True \/ cons0 False + coseries rs d = [ \x -> if x then r1 else r2 + | r1 <- rs d, r2 <- rs d ] + +instance Serial a => Serial (Maybe a) where + series = cons0 Nothing \/ cons1 Just + coseries rs d = [ \m -> case m of + Nothing -> z + Just x -> f x + | z <- alts0 rs d , + f <- alts1 rs d ] + +instance (Serial a, Serial b) => Serial (Either a b) where + series = cons1 Left \/ cons1 Right + coseries rs d = [ \e -> case e of + Left x -> f x + Right y -> g y + | f <- alts1 rs d , + g <- alts1 rs d ] + +instance Serial a => Serial [a] where + series = cons0 [] \/ cons2 (:) + coseries rs d = [ \xs -> case xs of + [] -> y + (x:xs') -> f x xs' + | y <- alts0 rs d , + f <- alts2 rs d ] + +-- Thanks to Ralf Hinze for the definition of coseries +-- using the nest auxiliary. + +instance (Serial a, Serial b) => Serial (a->b) where + series = coseries series + coseries rs d = + [ \ f -> g [ f a | a <- args ] + | g <- nest args d ] + where + args = series d + nest [] _ = [ \[] -> c + | c <- rs d ] + nest (a:as) _ = [ \(b:bs) -> f b bs + | f <- coseries (nest as) d ] + +-- For customising the depth measure. Use with care! + +depth :: Int -> Int -> Int +depth d d' | d >= 0 = d'+1-d + | otherwise = error "SmallCheck.depth: argument < 0" + +dec :: Int -> Int +dec d | d > 0 = d-1 + | otherwise = error "SmallCheck.dec: argument <= 0" + +inc :: Int -> Int +inc d = d+1 + +-- show the extension of a function (in part, bounded both by +-- the number and depth of arguments) +instance (Serial a, Show a, Show b) => Show (a->b) where + show f = + if maxarheight == 1 + && sumarwidth + length ars * length "->;" < widthLimit then + "{"++( + concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars] + )++"}" + else + concat $ [a++"->\n"++indent r | (a,r) <- ars] + where + ars = take lengthLimit [ (show x, show (f x)) + | x <- series depthLimit ] + maxarheight = maximum [ max (height a) (height r) + | (a,r) <- ars ] + sumarwidth = sum [ length a + length r + | (a,r) <- ars] + indent = unlines . map (" "++) . lines + height = length . lines + (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Int) + +---------------- ------------------ + +-- adapted from QuickCheck originals: here results come in lists, +-- properties have depth arguments, stamps (for classifying random +-- tests) are omitted, existentials are introduced + +newtype PR = Prop [Result] + +data Result = Result {ok :: Maybe Bool, arguments :: [String]} + +nothing :: Result +nothing = Result {ok = Nothing, arguments = []} + +result :: Result -> PR +result res = Prop [res] + +newtype Property = Property (Int -> PR) + +class Testable a where + property :: a -> Int -> PR + +instance Testable Bool where + property b _ = Prop [Result (Just b) []] + +instance Testable PR where + property prop _ = prop + +instance (Serial a, Show a, Testable b) => Testable (a->b) where + property f = f' where Property f' = forAll series f + +instance Testable Property where + property (Property f) d = f d + +-- For testing properties involving IO. Unsafe, so use with care! +instance Testable a => Testable (IO a) where + property = property . unsafePerformIO + +evaluate :: Testable a => a -> Series Result +evaluate x d = rs where Prop rs = property x d + +forAll :: (Show a, Testable b) => Series a -> (a->b) -> Property +forAll xs f = Property $ \d -> Prop $ + [ r{arguments = show x : arguments r} + | x <- xs d, r <- evaluate (f x) d ] + +forAllElem :: (Show a, Testable b) => [a] -> (a->b) -> Property +forAllElem xs = forAll (const xs) + +existence :: (Show a, Testable b) => Bool -> Series a -> (a->b) -> Property +existence u xs f = Property existenceDepth + where + existenceDepth d = Prop [ Result (Just valid) arguments ] + where + witnesses = [ show x | x <- xs d, all pass (evaluate (f x) d) ] + valid = enough witnesses + enough = if u then unique else (not . null) + arguments = if valid then [] + else if null witnesses then ["non-existence"] + else "non-uniqueness" : take 2 witnesses + +unique :: [a] -> Bool +unique [_] = True +unique _ = False + +pass :: Result -> Bool +pass (Result Nothing _) = True +pass (Result (Just b) _) = b + +thereExists :: (Show a, Testable b) => Series a -> (a->b) -> Property +thereExists = existence False + +thereExists1 :: (Show a, Testable b) => Series a -> (a->b) -> Property +thereExists1 = existence True + +thereExistsElem :: (Show a, Testable b) => [a] -> (a->b) -> Property +thereExistsElem xs = thereExists (const xs) + +thereExists1Elem :: (Show a, Testable b) => [a] -> (a->b) -> Property +thereExists1Elem xs = thereExists1 (const xs) + +exists :: (Show a, Serial a, Testable b) => (a->b) -> Property +exists = thereExists series + +exists1 :: (Show a, Serial a, Testable b) => (a->b) -> Property +exists1 = thereExists1 series + +existsDeeperBy :: (Show a, Serial a, Testable b) => (Int->Int) -> (a->b) -> Property +existsDeeperBy f = thereExists (series . f) + +exists1DeeperBy :: (Show a, Serial a, Testable b) => (Int->Int) -> (a->b) -> Property +exists1DeeperBy f = thereExists1 (series . f) + +infixr 0 ==> + +(==>) :: Testable a => Bool -> a -> Property +True ==> x = Property (property x) +False ==> x = Property (const (result nothing)) + +--------------------- ---------------------- + +-- similar in spirit to QuickCheck but with iterative deepening + +test :: Testable a => a -> IO () +test = smallCheckI + +-- test for values of depths 0..d stopping when a property +-- fails or when it has been checked for all these values +smallCheck :: Testable a => Int -> a -> IO () +smallCheck d = iterCheck 0 (Just d) + +-- interactive variant, asking the user whether testing should +-- continue/go deeper after a failure/completed iteration +smallCheckI :: Testable a => a -> IO () +smallCheckI = iterCheck 0 Nothing + +depthCheck :: Testable a => Int -> a -> IO () +depthCheck d = iterCheck d (Just d) + +iterCheck :: Testable a => Int -> Maybe Int -> a -> IO () +iterCheck dFrom mdTo t = iter dFrom + where + iter d = do + putStrLn ("Depth "++show d++":") + let Prop results = property t d + ok <- check (mdTo==Nothing) 0 0 True results + maybe (whenUserWishes " Deeper" () $ iter (d+1)) + (\dTo -> when (ok && d < dTo) $ iter (d+1)) + mdTo + +check :: Bool -> Integer -> Integer -> Bool -> [Result] -> IO Bool +check i n x ok rs | null rs = do + putStr (" Completed "++show n++" test(s)") + putStrLn (if ok then " without failure." else ".") + when (x > 0) $ + putStrLn (" But "++show x++" did not meet ==> condition.") + return ok +check i n x ok (Result Nothing _ : rs) = do + progressReport i n x + check i (n+1) (x+1) ok rs +check i n x f (Result (Just True) _ : rs) = do + progressReport i n x + check i (n+1) x f rs +check i n x f (Result (Just False) args : rs) = do + putStrLn (" Failed test no. "++show (n+1)++". Test values follow.") + mapM_ (putStrLn . (" "++)) args + ( if i then + whenUserWishes " Continue" False $ check i (n+1) x False rs + else + return False ) + +whenUserWishes :: String -> a -> IO a -> IO a +whenUserWishes wish x action = do + putStr (wish++"? ") + hFlush stdout + reply <- getLine + ( if (null reply || reply=="y") then action + else return x ) + +progressReport :: Bool -> Integer -> Integer -> IO () +progressReport i n x | n >= x = do + when i $ ( putStr (n' ++ replicate (length n') '\b') >> + hFlush stdout ) + where + n' = show n + +main = print not diff --git a/tests/bugs/Parsing1.expected.stdout b/tests/bugs/Parsing1.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/bugs/Parsing1.expected.stdout diff --git a/tests/bugs/Parsing1.hs b/tests/bugs/Parsing1.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/Parsing1.hs @@ -0,0 +1,6 @@ + +x :: Int +x = 0; + +main :: IO () +main = return () diff --git a/tests/bugs/Qualify1.expected.stdout b/tests/bugs/Qualify1.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/bugs/Qualify1.expected.stdout diff --git a/tests/bugs/Qualify1.hs b/tests/bugs/Qualify1.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/Qualify1.hs @@ -0,0 +1,20 @@ +module Main where + +import qualified Prelude as P + +data T = T + +-- GHC doesn't allow: T.show T = "T". What does the haskell98 doc say? +{- + idecls -> { idecl_1 ; ... ; idecl_n } (n>=0) + idecl -> (funlhs | var) rhs + | (empty) +-} +-- var, of course, does not permit qnames. + +instance P.Show T where + show T = "T" + +main :: P.IO () +main = P.return () + diff --git a/tests/bugs/RayT.args b/tests/bugs/RayT.args new file mode 100644 --- /dev/null +++ b/tests/bugs/RayT.args @@ -0,0 +1,1 @@ +2 100 diff --git a/tests/bugs/RayT.expected.stdout b/tests/bugs/RayT.expected.stdout new file mode 100644 Binary files /dev/null and b/tests/bugs/RayT.expected.stdout differ diff --git a/tests/bugs/RayT.hs b/tests/bugs/RayT.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/RayT.hs @@ -0,0 +1,95 @@ +import System +infinity = 1/0 +delta = sqrt e where e = encodeFloat (floatRadix e) (-floatDigits e) +infixl 7 .*, *| +data Vector = V !Double !Double !Double deriving (Show, Eq) +s *| V x y z = V (s * x) (s * y) (s * z) +instance Num Vector where + V x y z + V x' y' z' = V (x + x') (y + y') (z + z') + V x y z - V x' y' z' = V (x - x') (y - y') (z - z') + fromInteger i = V x x x where x = fromInteger i +V x y z .* V x' y' z' = x * x' + y * y' + z * z' +vlength r = sqrt (r .* r) +unitise r = 1 / vlength r *| r + +data Scene + = Sphere !Vector !Double + | Group !Vector !Double Scene Scene Scene Scene Scene + deriving (Show) + +ray_sphere (V dx dy dz) (V vx vy vz) r = + let disc = vx * vx + vy * vy + vz * vz - r * r + in if disc < 0 then infinity else + let b = vx * dx + vy * dy + vz * dz + b2 = b * b + in if b2 < disc then infinity else + let disk = sqrt(b2 - disc) + t1 = b - disk + in if t1 > 0 then t1 else b + disk + +ray_sphere' (V ox oy oz) (V dx dy dz) (V cx cy cz) r = + let vx = cx - ox; vy = cy - oy; vz = cz - oz + vv = vx * vx + vy * vy + vz * vz + b = vx * dx + vy * dy + vz * dz + disc = b * b - vv + r * r + in disc >= 0 && b + sqrt disc >= 0 + +data Hit = H {l :: !Double, nv :: Vector } + +intersect dir@(V dx dy dz) hit s = case s of + Sphere center@(V cx cy cz) radius -> + let l' = ray_sphere dir center radius in + if l' >= l hit then hit else + let x = l' * dx - cx + y = l' * dy - cy + z = l' * dz - cz + il = 1 / sqrt(x * x + y * y + z * z) + in H {l = l', nv = V (il * x) (il * y) (il * z) } + Group center radius a b c d e -> + let l' = ray_sphere dir center radius in + if l' >= l hit then hit else + let f h s = intersect dir h s in + f (f (f (f (f hit a) b) c) d) e + +intersect' orig dir s = case s of + Sphere center radius -> ray_sphere' orig dir center radius + Group center radius a b c d e -> + let f s = intersect' orig dir s in + ray_sphere' orig dir center radius && (f a || f b || f c || f d || f e) + +neg_light = unitise (V 1 3 (-2)) + +ray_trace dir scene = + let hit = intersect dir (H infinity 0) scene in + if l hit == infinity then 0 else + let n = nv hit in + let g = n .* neg_light in + if g < 0 then 0 else + if intersect' (l hit *| dir + delta *| n) neg_light scene then 0 else g + +fold5 f x a b c d e = f (f (f (f (f x a) b) c) d) e + +create level c r = + let obj = Sphere c r in + if level == 1 then obj else + let a = 3 * r / sqrt 12 in + let bound (c, r) s = case s of + Sphere c' r' -> (c, max r (vlength (c - c') + r')) + Group _ _ v w x y z -> fold5 bound (c, r) v w x y z in + let aux x' z' = create (level - 1 :: Int) (c + V x' a z') (0.5 * r) in + let w = aux (-a) (-a); x = aux a (-a) in + let y = aux (-a) a; z = aux a a in + let (c1, r1) = fold5 bound (c + V 0 r 0, 0) obj w x y z in + Group c1 r1 obj w x y z + +ss = 4 +pixel_vals n scene y x = sum + [ let f a da = a - n / 2 + da / ss; d = unitise (V (f x dx) (f y dy) n) + in ray_trace d scene | dx <- [0..ss-1], dy <- [0..ss-1] ] +main = do + [level,ni] <- fmap (map read) getArgs + let n = fromIntegral ni + scene = create level (V 0 (-1) 4) 1 + scale x = 0.5 + 255 * x / (ss*ss) + picture = [ toEnum $ truncate $ scale $ pixel_vals n scene y x | y <- [n-1,n-2..0], x <- [0..n-1]] + putStrLn $ "P5\n" ++ show ni ++ " " ++ show ni ++ "\n255\n" ++ picture diff --git a/tests/bugs/RayT.mustfail b/tests/bugs/RayT.mustfail new file mode 100644 --- /dev/null +++ b/tests/bugs/RayT.mustfail diff --git a/tests/bugs/Recursive2.expected.stdout b/tests/bugs/Recursive2.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/bugs/Recursive2.expected.stdout diff --git a/tests/bugs/Recursive2.hs b/tests/bugs/Recursive2.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/Recursive2.hs @@ -0,0 +1,6 @@ + +a = b +b = a + +main :: IO () +main = return () diff --git a/tests/bugs/UnpackedPoly.expected.stdout b/tests/bugs/UnpackedPoly.expected.stdout new file mode 100644 --- /dev/null +++ b/tests/bugs/UnpackedPoly.expected.stdout @@ -0,0 +1,1 @@ +Bar (Foo ["Hi!"]) diff --git a/tests/bugs/UnpackedPoly.hs b/tests/bugs/UnpackedPoly.hs new file mode 100644 --- /dev/null +++ b/tests/bugs/UnpackedPoly.hs @@ -0,0 +1,7 @@ +-- This triggers the same issue that prevents HashTable from building + +data Foo a = Foo [a] deriving Show + +data Bar a = Bar !(Foo a) deriving Show + +main = print (Bar (Foo ["Hi!"]))