packages feed

lhc 0.8 → 0.10

raw patch · 404 files changed

+37818/−10328 lines, 404 filesdep +HUnitdep +QuickCheckdep +paralleldep −ghcdep −libffisetup-changedbinary-added

Dependencies added: HUnit, QuickCheck, parallel, test-framework, test-framework-hunit, test-framework-quickcheck, time

Dependencies removed: ghc, libffi

Files

Setup.hs view
@@ -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
lhc-pkg/Main.hs view
@@ -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")
lhc-regress/Main.hs view
@@ -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+        ]
+ lhc-regress/Properties.hs view
@@ -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))+
− lhc-regress/Setup.hs 
@@ -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 <n> 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
− lhc-regress/TestCase.hs 
@@ -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--
lhc.cabal view
@@ -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
+ lib/base/Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
− lib/base/Setup.lhs 
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
lib/base/base.cabal view
@@ -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 }
+ lib/base/src/Control/Applicative.hs view
@@ -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+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+-- This interface was introduced for parsers by Niklas R&#xF6;jemo, because+-- it admits more sharing than the monadic interface.  The names here are+-- mostly based on 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
+ lib/base/src/Control/Arrow.hs view
@@ -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+-- <http://www.haskell.org/arrows/>.++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)
+ lib/base/src/Control/Category.hs view
@@ -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
+ lib/base/src/Control/Concurrent.hs view
@@ -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/+<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.++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\<n\>@ 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__ */
lib/base/src/Control/Exception.hs view
@@ -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)
lib/base/src/Control/Exception/Base.hs view
@@ -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"))
lib/base/src/Control/Monad.hs view
@@ -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
+ lib/base/src/Control/Monad/Fix.hs view
@@ -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+
+ lib/base/src/Control/Monad/Instances.hs view
@@ -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)
+ lib/base/src/Control/Monad/ST.hs view
@@ -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+
+ lib/base/src/Control/Monad/ST/Lazy.hs view
@@ -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
+ lib/base/src/Control/Monad/ST/Strict.hs view
@@ -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
+ lib/base/src/Control/OldException.hs view
@@ -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+
lib/base/src/Data/Bits.hs view
@@ -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
+ lib/base/src/Data/Bool.hs view
@@ -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
lib/base/src/Data/Char.hs view
@@ -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__
+ lib/base/src/Data/Complex.hs view
@@ -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))
+ lib/base/src/Data/Data.hs view
@@ -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 <http://www.cs.vu.nl/boilerplate/>. 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: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.+--+--+-----------------------------------------------------------------------------++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"+
lib/base/src/Data/Dynamic.hs view
@@ -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
lib/base/src/Data/Either.hs view
@@ -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)  {- {--------------------------------------------------------------------
+ lib/base/src/Data/Eq.hs view
@@ -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
+ lib/base/src/Data/Fixed.hs view
@@ -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 <ashley@semantic.org>+-- 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
+ lib/base/src/Data/Foldable.hs view
@@ -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 [])
+ lib/base/src/Data/Function.hs view
@@ -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 @(*) &#x2209; {&#x22a5;, 'const' &#x22a5;}@)+--+-- * @((*) \`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
+ lib/base/src/Data/Functor.hs view
@@ -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
lib/base/src/Data/HashTable.hs view
@@ -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 } )
lib/base/src/Data/IORef.hs view
@@ -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
lib/base/src/Data/Ix.hs view
@@ -60,7 +60,7 @@      ) where -import Prelude+-- import Prelude  #ifdef __GLASGOW_HASKELL__ import GHC.Arr
lib/base/src/Data/List.hs view
@@ -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 <igloo@earth.li>@@ -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]
+ lib/base/src/Data/Monoid.hs view
@@ -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+-- <http://en.wikipedia.org/wiki/Monoid>: \"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)+-- -}
+ lib/base/src/Data/Ord.hs view
@@ -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)
+ lib/base/src/Data/Ratio.hs view
@@ -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
+ lib/base/src/Data/STRef.hs view
@@ -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
+ lib/base/src/Data/STRef/Lazy.hs view
@@ -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)
+ lib/base/src/Data/STRef/Strict.hs view
@@ -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
+ lib/base/src/Data/String.hs view
@@ -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+
+ lib/base/src/Data/Traversable.hs view
@@ -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+--    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+--  * /The Essence of the Iterator Pattern/,+--    by Jeremy Gibbons and Bruno Oliveira,+--    in /Mathematically-Structured Functional Programming/, 2006, and online at+--    <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.+--+-- 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)
lib/base/src/Data/Tuple.hs view
@@ -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)
lib/base/src/Data/Typeable.hs view
@@ -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
lib/base/src/Data/Typeable.hs-boot view
@@ -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
+ lib/base/src/Data/Unique.hs view
@@ -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
+ lib/base/src/Data/Version.hs view
@@ -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}
+ lib/base/src/Debug/Trace.hs view
@@ -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
lib/base/src/Foreign/C/Error.hsc view
@@ -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
lib/base/src/Foreign/C/String.hs view
@@ -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 )
lib/base/src/Foreign/C/Types.hs view
@@ -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))+  #-}+
+ lib/base/src/Foreign/Concurrent.hs view
@@ -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
lib/base/src/Foreign/ForeignPtr.hs view
@@ -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
lib/base/src/Foreign/Marshal/Alloc.hs view
@@ -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
lib/base/src/Foreign/Marshal/Array.hs view
@@ -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 --
lib/base/src/Foreign/Marshal/Error.hs view
@@ -37,7 +37,8 @@ #endif import GHC.Base import GHC.Num-import GHC.IOBase+-- import GHC.IO+import GHC.IO.Exception #endif  -- exported functions
lib/base/src/Foreign/Marshal/Pool.hs view
@@ -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)
lib/base/src/Foreign/Marshal/Utils.hs view
@@ -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 ()
lib/base/src/Foreign/Ptr.hs view
@@ -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
lib/base/src/Foreign/Storable.hs view
@@ -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)
− lib/base/src/Foreign/Storable.hs-boot 
@@ -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-
lib/base/src/GHC/Arr.lhs view
@@ -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)]
lib/base/src/GHC/Base.lhs view
@@ -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--- <wired into compiler>:---     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
lib/base/src/GHC/Classes.hs view
@@ -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...:
lib/base/src/GHC/Conc.lhs view
@@ -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}
+ lib/base/src/GHC/ConsoleHandler.hs view
@@ -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 */
+ lib/base/src/GHC/Constants.hs view
@@ -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"
+ lib/base/src/GHC/Desugar.hs view
@@ -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
lib/base/src/GHC/Enum.lhs view
@@ -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
+ lib/base/src/GHC/Environment.hs view
@@ -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 ()+
lib/base/src/GHC/Err.lhs-boot view
@@ -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}
lib/base/src/GHC/Exception.lhs view
@@ -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}
+ lib/base/src/GHC/Exts.hs view
@@ -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', () #)
lib/base/src/GHC/Float.lhs view
@@ -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
lib/base/src/GHC/ForeignPtr.hs view
@@ -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 ->
lib/base/src/GHC/Handle.hs view
@@ -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 "<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 "<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 "<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 = "<file descriptor: " ++ show fd ++ ">"-   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
− lib/base/src/GHC/Handle.hs-boot 
@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -XNoImplicitPrelude #-}--module GHC.Handle where--import GHC.IOBase--stdout :: Handle-stderr :: Handle-hFlush :: Handle -> IO ()
lib/base/src/GHC/IO.hs view
@@ -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
+ lib/base/src/GHC/IO.hs-boot view
@@ -0,0 +1,5 @@+module GHC.IO where++import GHC.Types++failIO :: [Char] -> IO a
+ lib/base/src/GHC/IO/Buffer.hs view
@@ -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)
+ lib/base/src/GHC/IO/BufferedIO.hs view
@@ -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)
+ lib/base/src/GHC/IO/Device.hs view
@@ -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)
+ lib/base/src/GHC/IO/Encoding.hs view
@@ -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
+ lib/base/src/GHC/IO/Encoding/CodePage.hs view
@@ -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
+ lib/base/src/GHC/IO/Encoding/CodePage/Table.hs view
@@ -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'+        }++   }+    )+    ]
+ lib/base/src/GHC/IO/Encoding/Iconv.hs view
@@ -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 */
+ lib/base/src/GHC/IO/Encoding/Latin1.hs view
@@ -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)
+ lib/base/src/GHC/IO/Encoding/Types.hs view
@@ -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)+  }
+ lib/base/src/GHC/IO/Encoding/UTF16.hs view
@@ -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 #-}
+ lib/base/src/GHC/IO/Encoding/UTF32.hs view
@@ -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 #-}
+ lib/base/src/GHC/IO/Encoding/UTF8.hs view
@@ -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
+ lib/base/src/GHC/IO/Exception.hs view
@@ -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 "<<deadlock>>"++-----++-- |'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 /= '|'
+ lib/base/src/GHC/IO/Exception.hs-boot view
@@ -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
+ lib/base/src/GHC/IO/FD.hs view
@@ -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 ()
+ lib/base/src/GHC/IO/Handle.hs view
@@ -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
+ lib/base/src/GHC/IO/Handle.hs-boot view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.IO.Handle where++import GHC.IO+import GHC.IO.Handle.Types++hFlush :: Handle -> IO ()
+ lib/base/src/GHC/IO/Handle/FD.hs view
@@ -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 "<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 "<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 "<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 = "<file descriptor: " ++ show fd ++ ">"+   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
+ lib/base/src/GHC/IO/Handle/FD.hs-boot view
@@ -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
+ lib/base/src/GHC/IO/Handle/Internals.hs view
@@ -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'
+ lib/base/src/GHC/IO/Handle/Text.hs view
@@ -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)
+ lib/base/src/GHC/IO/Handle/Types.hs view
@@ -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 "}"
+ lib/base/src/GHC/IO/IOMode.hs view
@@ -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)
+ lib/base/src/GHC/IOArray.hs view
@@ -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
+ lib/base/src/GHC/IOBase.hs view
@@ -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
− lib/base/src/GHC/IOBase.lhs 
@@ -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 "<<deadlock>>"----------- |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}-
+ lib/base/src/GHC/IORef.hs view
@@ -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+
lib/base/src/GHC/Int.hs view
@@ -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-
lib/base/src/GHC/List.lhs view
@@ -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)
+ lib/base/src/GHC/MVar.hs view
@@ -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, () #) }+
lib/base/src/GHC/Num.lhs view
@@ -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
+ lib/base/src/GHC/PArr.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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__ */+
lib/base/src/GHC/Pack.lhs view
@@ -35,7 +35,6 @@         where  import GHC.Base-import GHC.Err ( error ) import GHC.List ( length ) import GHC.ST import GHC.Num
lib/base/src/GHC/Ptr.lhs view
@@ -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}
lib/base/src/GHC/Read.lhs view
@@ -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
lib/base/src/GHC/Real.lhs view
@@ -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)]
lib/base/src/GHC/Show.lhs view
@@ -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#))
+ lib/base/src/GHC/Show.lhs-boot view
@@ -0,0 +1,10 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Show (showSignedInt) where++import GHC.Types++showSignedInt :: Int -> Int -> [Char] -> [Char]+\end{code}+
lib/base/src/GHC/Stable.lhs view
@@ -27,7 +27,7 @@  import GHC.Ptr import GHC.Base-import GHC.IOBase+-- import GHC.IO  ----------------------------------------------------------------------------- -- Stable Pointers
lib/base/src/GHC/Storable.lhs view
@@ -55,7 +55,6 @@ import GHC.Int import GHC.Word import GHC.Ptr-import GHC.IOBase import GHC.Base \end{code}
lib/base/src/GHC/Unicode.hs view
@@ -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
+ lib/base/src/GHC/Weak.lhs view
@@ -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}
lib/base/src/GHC/Word.hs view
@@ -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#
lib/base/src/Prelude.hs view
@@ -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__ */
− lib/base/src/Prelude.hs-boot 
@@ -1,7 +0,0 @@-{-# OPTIONS_GHC -XNoImplicitPrelude #-}--module Prelude where--import GHC.IOBase--catch :: IO a -> (IOError -> IO a) -> IO a
+ lib/base/src/System/Console/GetOpt.hs view
@@ -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 <Sven.Panne@informatik.uni-muenchen.de> 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.++-}
lib/base/src/System/Environment.hs view
@@ -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 ()
+ lib/base/src/System/Exit.hs view
@@ -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
lib/base/src/System/IO.hs view
@@ -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
lib/base/src/System/IO/Error.hs view
@@ -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__ */
lib/base/src/System/IO/Unsafe.hs view
@@ -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
+ lib/base/src/System/Info.hs view
@@ -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
+ lib/base/src/System/Mem.hs view
@@ -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
+ lib/base/src/System/Mem/StableName.hs view
@@ -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")
+ lib/base/src/System/Mem/Weak.hs view
@@ -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.+-}
lib/base/src/System/Posix/Internals.hs view
@@ -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
lib/base/src/System/Posix/Types.hs view
@@ -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)
+ lib/base/src/System/Timeout.hs view
@@ -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 _ = "<<timeout>>"++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__ */
+ lib/ghc-prim/GHC/Debug.hs view
@@ -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'+
lib/ghc-prim/GHC/Generics.hs view
@@ -1,5 +1,4 @@--{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -XNoImplicitPrelude -XTypeOperators #-}  module GHC.Generics where
lib/ghc-prim/GHC/IntWord32.hs view
@@ -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
lib/ghc-prim/GHC/IntWord64.hs view
@@ -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#
+ lib/ghc-prim/GHC/Magic.hs view
@@ -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+
− lib/ghc-prim/GHC/Prim.hs 
@@ -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---
lib/ghc-prim/GHC/PrimopWrappers.hs view
@@ -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
lib/ghc-prim/GHC/Types.hs view
@@ -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 #))
lib/ghc-prim/Setup.hs view
@@ -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 }
− lib/ghc-prim/cbits/longlong.c 
@@ -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 */
lib/ghc-prim/ghc-prim.cabal view
@@ -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)
+ lib/integer-ltm/LICENSE view
@@ -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.++-----------------------------------------------------------------------------
+ lib/integer-ltm/Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ lib/integer-ltm/integer.cabal view
@@ -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+}
+ lib/integer-ltm/src/GHC/Integer.hs view
@@ -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+
+ lib/integer-ltm/src/GHC/Integer/Ltm.hs view
@@ -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+
+ lib/integer-ltm/src/GHC/Integer/Type.hs view
@@ -0,0 +1,6 @@+module GHC.Integer.Type where+++import GHC.Integer.Ltm++data Integer = Integer Mp_int
− lib/integer-native/LICENSE 
@@ -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.-------------------------------------------------------------------------------
− lib/integer-native/Setup.lhs 
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
− lib/integer-native/integer.cabal 
@@ -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-}
− lib/integer-native/src/GHC/Integer.hs 
@@ -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-
− lib/integer-native/src/GHC/Integer/Internals.hs 
@@ -1,7 +0,0 @@-module GHC.Integer.Internals where--import GHC.Prim-import GHC.Types--data Integer = Integer Int#-
+ rts/ltm/bn_error.c view
@@ -0,0 +1,47 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_fast_mp_invmod.c view
@@ -0,0 +1,148 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_fast_mp_montgomery_reduce.c view
@@ -0,0 +1,172 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_fast_s_mp_mul_digs.c view
@@ -0,0 +1,107 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_fast_s_mp_mul_high_digs.c view
@@ -0,0 +1,98 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_fast_s_mp_sqr.c view
@@ -0,0 +1,114 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_2expt.c view
@@ -0,0 +1,48 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_abs.c view
@@ -0,0 +1,43 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_add.c view
@@ -0,0 +1,53 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_add_d.c view
@@ -0,0 +1,112 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_addmod.c view
@@ -0,0 +1,41 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_and.c view
@@ -0,0 +1,57 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_clamp.c view
@@ -0,0 +1,44 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_clear.c view
@@ -0,0 +1,44 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_clear_multi.c view
@@ -0,0 +1,34 @@+#include <tommath.h>+#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 <stdarg.h>++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 $ */
+ rts/ltm/bn_mp_cmp.c view
@@ -0,0 +1,43 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_cmp_d.c view
@@ -0,0 +1,44 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_cmp_mag.c view
@@ -0,0 +1,55 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_cnt_lsb.c view
@@ -0,0 +1,53 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_copy.c view
@@ -0,0 +1,68 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_count_bits.c view
@@ -0,0 +1,45 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_div.c view
@@ -0,0 +1,292 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_div_2.c view
@@ -0,0 +1,68 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_div_2d.c view
@@ -0,0 +1,97 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_div_3.c view
@@ -0,0 +1,79 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_div_d.c view
@@ -0,0 +1,110 @@+#include <tommath.h>+#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)<<x)) {+         *p = x;+         return 1;+      }+   }+   return 0;+}++/* single digit division (based on routine from MPI) */+int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d)+{+  mp_int  q;+  mp_word w;+  mp_digit t;+  int     res, ix;++  /* cannot divide by zero */+  if (b == 0) {+     return MP_VAL;+  }++  /* quick outs */+  if (b == 1 || mp_iszero(a) == 1) {+     if (d != NULL) {+        *d = 0;+     }+     if (c != NULL) {+        return mp_copy(a, c);+     }+     return MP_OKAY;+  }++  /* power of two ? */+  if (s_is_power_of_two(b, &ix) == 1) {+     if (d != NULL) {+        *d = a->dp[0] & ((((mp_digit)1)<<ix) - 1);+     }+     if (c != NULL) {+        return mp_div_2d(a, ix, c, NULL);+     }+     return MP_OKAY;+  }++#ifdef BN_MP_DIV_3_C+  /* three? */+  if (b == 3) {+     return mp_div_3(a, c, d);+  }+#endif++  /* no easy answer [c'est la vie].  Just division */+  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 >= 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 $ */
+ rts/ltm/bn_mp_dr_is_modulus.c view
@@ -0,0 +1,43 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_dr_reduce.c view
@@ -0,0 +1,94 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_dr_setup.c view
@@ -0,0 +1,32 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_exch.c view
@@ -0,0 +1,34 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_expt_d.c view
@@ -0,0 +1,57 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_exptmod.c view
@@ -0,0 +1,112 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_exptmod_fast.c view
@@ -0,0 +1,321 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_exteuclid.c view
@@ -0,0 +1,82 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_fread.c view
@@ -0,0 +1,67 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_fwrite.c view
@@ -0,0 +1,52 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_gcd.c view
@@ -0,0 +1,105 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_get_int.c view
@@ -0,0 +1,45 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_grow.c view
@@ -0,0 +1,57 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_init.c view
@@ -0,0 +1,46 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_init_copy.c view
@@ -0,0 +1,32 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_init_multi.c view
@@ -0,0 +1,59 @@+#include <tommath.h>+#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 <stdarg.h>++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 $ */
+ rts/ltm/bn_mp_init_set.c view
@@ -0,0 +1,32 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_init_set_int.c view
@@ -0,0 +1,31 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_init_size.c view
@@ -0,0 +1,48 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_invmod.c view
@@ -0,0 +1,43 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_invmod_slow.c view
@@ -0,0 +1,175 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_is_square.c view
@@ -0,0 +1,109 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_jacobi.c view
@@ -0,0 +1,105 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_karatsuba_mul.c view
@@ -0,0 +1,167 @@+#include <tommath.h>+#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))<<B */+  if (mp_lshd (&x1y1, B * 2) != MP_OKAY)+    goto X1Y1;          /* x1y1 = x1y1 << 2*B */++  if (mp_add (&x0y0, &t1, &t1) != MP_OKAY)+    goto X1Y1;          /* t1 = x0y0 + t1 */+  if (mp_add (&t1, &x1y1, c) != MP_OKAY)+    goto X1Y1;          /* t1 = x0y0 + t1 + x1y1 */++  /* Algorithm succeeded set the return code to MP_OKAY */+  err = MP_OKAY;++X1Y1:mp_clear (&x1y1);+X0Y0:mp_clear (&x0y0);+T1:mp_clear (&t1);+Y1:mp_clear (&y1);+Y0:mp_clear (&y0);+X1:mp_clear (&x1);+X0:mp_clear (&x0);+ERR:+  return err;+}+#endif++/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_mul.c,v $ */+/* $Revision: 1.5 $ */+/* $Date: 2006/03/31 14:18:44 $ */
+ rts/ltm/bn_mp_karatsuba_sqr.c view
@@ -0,0 +1,121 @@+#include <tommath.h>+#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))<<B */+  if (mp_lshd (&x1x1, B * 2) != MP_OKAY)+    goto X1X1;           /* x1x1 = x1x1 << 2*B */++  if (mp_add (&x0x0, &t1, &t1) != MP_OKAY)+    goto X1X1;           /* t1 = x0x0 + t1 */+  if (mp_add (&t1, &x1x1, b) != MP_OKAY)+    goto X1X1;           /* t1 = x0x0 + t1 + x1x1 */++  err = MP_OKAY;++X1X1:mp_clear (&x1x1);+X0X0:mp_clear (&x0x0);+T2:mp_clear (&t2);+T1:mp_clear (&t1);+X1:mp_clear (&x1);+X0:mp_clear (&x0);+ERR:+  return err;+}+#endif++/* $Source: /cvs/libtom/libtommath/bn_mp_karatsuba_sqr.c,v $ */+/* $Revision: 1.5 $ */+/* $Date: 2006/03/31 14:18:44 $ */
+ rts/ltm/bn_mp_lcm.c view
@@ -0,0 +1,60 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_lshd.c view
@@ -0,0 +1,67 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mod.c view
@@ -0,0 +1,48 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mod_2d.c view
@@ -0,0 +1,55 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mod_d.c view
@@ -0,0 +1,27 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_montgomery_calc_normalization.c view
@@ -0,0 +1,59 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_montgomery_reduce.c view
@@ -0,0 +1,118 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_montgomery_setup.c view
@@ -0,0 +1,59 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mul.c view
@@ -0,0 +1,66 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mul_2.c view
@@ -0,0 +1,82 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mul_2d.c view
@@ -0,0 +1,85 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mul_d.c view
@@ -0,0 +1,79 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_mulmod.c view
@@ -0,0 +1,40 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_n_root.c view
@@ -0,0 +1,132 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_neg.c view
@@ -0,0 +1,40 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_or.c view
@@ -0,0 +1,50 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_prime_fermat.c view
@@ -0,0 +1,62 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_prime_is_divisible.c view
@@ -0,0 +1,50 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_prime_is_prime.c view
@@ -0,0 +1,83 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_prime_miller_rabin.c view
@@ -0,0 +1,103 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_prime_next_prime.c view
@@ -0,0 +1,170 @@+#include <tommath.h>+#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)<<DIGIT_BIT) - kstep));++      /* add the step */+      if ((err = mp_add_d(a, step, a)) != MP_OKAY) {+         goto LBL_ERR;+      }++      /* if didn't pass sieve and step == MAX then skip test */+      if (y == 1 && step >= ((((mp_digit)1)<<DIGIT_BIT) - kstep)) {+         continue;+      }++      /* is this prime? */+      for (x = 0; x < t; x++) {+          mp_set(&b, ltm_prime_tab[t]);+          if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {+             goto LBL_ERR;+          }+          if (res == MP_NO) {+             break;+          }+      }++      if (res == MP_YES) {+         break;+      }+   }++   err = MP_OKAY;+LBL_ERR:+   mp_clear(&b);+   return err;+}++#endif++/* $Source: /cvs/libtom/libtommath/bn_mp_prime_next_prime.c,v $ */+/* $Revision: 1.3 $ */+/* $Date: 2006/03/31 14:18:44 $ */
+ rts/ltm/bn_mp_prime_rabin_miller_trials.c view
@@ -0,0 +1,52 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_prime_random_ex.c view
@@ -0,0 +1,125 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_radix_size.c view
@@ -0,0 +1,78 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_radix_smap.c view
@@ -0,0 +1,24 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_rand.c view
@@ -0,0 +1,55 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_read_radix.c view
@@ -0,0 +1,85 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_read_signed_bin.c view
@@ -0,0 +1,41 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_read_unsigned_bin.c view
@@ -0,0 +1,55 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce.c view
@@ -0,0 +1,100 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_2k.c view
@@ -0,0 +1,61 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_2k_l.c view
@@ -0,0 +1,62 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_2k_setup.c view
@@ -0,0 +1,47 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_2k_setup_l.c view
@@ -0,0 +1,44 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_is_2k.c view
@@ -0,0 +1,52 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_is_2k_l.c view
@@ -0,0 +1,44 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_reduce_setup.c view
@@ -0,0 +1,34 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_rshd.c view
@@ -0,0 +1,72 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_set.c view
@@ -0,0 +1,29 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_set_int.c view
@@ -0,0 +1,48 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_shrink.c view
@@ -0,0 +1,35 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_signed_bin_size.c view
@@ -0,0 +1,27 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_sqr.c view
@@ -0,0 +1,58 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_sqrmod.c view
@@ -0,0 +1,41 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_sqrt.c view
@@ -0,0 +1,81 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_sub.c view
@@ -0,0 +1,59 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_sub_d.c view
@@ -0,0 +1,93 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_submod.c view
@@ -0,0 +1,42 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_to_signed_bin.c view
@@ -0,0 +1,33 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_to_signed_bin_n.c view
@@ -0,0 +1,31 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_to_unsigned_bin.c view
@@ -0,0 +1,48 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_to_unsigned_bin_n.c view
@@ -0,0 +1,31 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_toom_mul.c view
@@ -0,0 +1,284 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_toom_sqr.c view
@@ -0,0 +1,226 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_toradix.c view
@@ -0,0 +1,75 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_toradix_n.c view
@@ -0,0 +1,88 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_unsigned_bin_size.c view
@@ -0,0 +1,28 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_xor.c view
@@ -0,0 +1,51 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_mp_zero.c view
@@ -0,0 +1,36 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_prime_tab.c view
@@ -0,0 +1,61 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_reverse.c view
@@ -0,0 +1,39 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_s_mp_add.c view
@@ -0,0 +1,109 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_s_mp_exptmod.c view
@@ -0,0 +1,252 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_s_mp_mul_digs.c view
@@ -0,0 +1,90 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_s_mp_mul_high_digs.c view
@@ -0,0 +1,81 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_s_mp_sqr.c view
@@ -0,0 +1,84 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bn_s_mp_sub.c view
@@ -0,0 +1,89 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/bncore.c view
@@ -0,0 +1,36 @@+#include <tommath.h>+#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 $ */
+ rts/ltm/tommath.h view
@@ -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 <stdio.h>+#include <string.h>+#include <stdlib.h>+#include <ctype.h>+#include <limits.h>++#include <tommath_class.h>++#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 $ */
+ rts/ltm/tommath_class.h view
@@ -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 <tommath_superclass.h>+#include <tommath_class.h>+#else+#define LTM_LAST+#endif++/* $Source: /cvs/libtom/libtommath/tommath_class.h,v $ */+/* $Revision: 1.3 $ */+/* $Date: 2005/07/28 11:59:32 $ */
+ rts/ltm/tommath_superclass.h view
@@ -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 $ */
+ rts/rts.c view
@@ -0,0 +1,227 @@+/* Header: */+#include <stdlib.h>+#include <stdio.h>+#include <unistd.h>+#include <string.h>+#include <math.h>+#include <errno.h>+#include <gc.h>++#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;+}+*/
+ rts/rts.ll view
@@ -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.
src/GhcMain.hs view
@@ -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<size>---------------------------------------------------------------------------------- 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 <suffix> 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 ()
+ src/Grin/DeadCode.hs view
@@ -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+
src/Grin/Eval/Compile.hs view
@@ -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
src/Grin/Eval/Methods.hs view
@@ -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
src/Grin/Eval/Primitives.hs view
@@ -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))
src/Grin/Eval/Types.hs view
@@ -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
src/Grin/FromCore.hs view
@@ -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
src/Grin/HPT.hs view
@@ -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
src/Grin/HPT/Environment.hs view
@@ -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
+ src/Grin/HPT/FastSolve.hs view
@@ -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)}++
+ src/Grin/HPT/Interface.hs view
@@ -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) }+
src/Grin/HPT/Lower.hs view
@@ -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
+ src/Grin/HPT/QuickSolve.hs view
@@ -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)+-}
src/Grin/HPT/Solve.hs view
@@ -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)
− src/Grin/HtmlAnnotate.hs 
@@ -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++"</"++t++">"--(<$$>) = ($$)-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 ("<a href=\"#"++ show ident ++"\">") <> text var <> zeroWidthText "</a>"--setAnchor ident var-    = zeroWidthText ("<a name=\""++ show ident ++"\">") <> text var <> zeroWidthText "</a>"-
src/Grin/Lowering/Apply.hs view
@@ -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)
src/Grin/Lowering/GHCism.hs view
@@ -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)
+ src/Grin/Optimize/Case.hs view
@@ -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+
+ src/Grin/Optimize/Inline.hs view
@@ -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++++
src/Grin/Optimize/Simple.hs view
@@ -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+
+ src/Grin/PreciseDeadCode.hs view
@@ -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)+
src/Grin/Pretty.hs view
@@ -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)
src/Grin/SimpleCore.hs view
@@ -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
src/Grin/SimpleCore/DeadCode.hs view
@@ -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)
src/Grin/SimpleCore/Types.hs view
@@ -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)
+ src/Grin/Stage2/Backend/C.hs view
@@ -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 '*')+++
+ src/Grin/Stage2/Backend/LLVM.hs view
@@ -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++-}++
+ src/Grin/Stage2/DeadCode.hs view
@@ -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+
+ src/Grin/Stage2/FromStage1.hs view
@@ -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)
+ src/Grin/Stage2/Optimize/Case.hs view
@@ -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)++
+ src/Grin/Stage2/Optimize/Simple.hs view
@@ -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+
+ src/Grin/Stage2/Pretty.hs view
@@ -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)
+ src/Grin/Stage2/Rename.hs view
@@ -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
+ src/Grin/Stage2/Transform.hs view
@@ -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+
+ src/Grin/Stage2/Types.hs view
@@ -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)+-}+
+ src/Grin/Transform.hs view
@@ -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+
src/Grin/Types.hs view
@@ -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]
+ src/HashMap.hs view
@@ -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)
+ src/HashSet.hs view
@@ -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
src/LhcMain.hs view
@@ -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+-}
+ src/Manager.hs view
@@ -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++-}
+ tests/1_io/basic/Args.args view
@@ -0,0 +1,1 @@+Foo Bar Baz
+ tests/1_io/basic/Args.expected.stdout view
@@ -0,0 +1,3 @@+Foo+Bar+Baz
+ tests/1_io/basic/Args.hs view
@@ -0,0 +1,6 @@+import System.Environment++main :: IO ()+main = do+    as <- getArgs+    mapM_ putStrLn as
+ tests/1_io/basic/Echo.expected.stdout view
@@ -0,0 +1,6 @@+MODULE MAIN WHERE++IMPORT DATA.CHAR++MAIN :: IO ()+MAIN = INTERACT (MAP TOUPPER)
+ tests/1_io/basic/Echo.hs view
@@ -0,0 +1,6 @@+module Main where++import Data.Char++main :: IO ()+main = interact (map toUpper)
+ tests/1_io/basic/Echo.stdin view
@@ -0,0 +1,6 @@+module Main where++import Data.Char++main :: IO ()+main = interact (map toUpper)
+ tests/1_io/basic/HelloWorld.expected.stdout view
@@ -0,0 +1,1 @@+Hello, World!
+ tests/1_io/basic/HelloWorld.hs view
@@ -0,0 +1,4 @@+++main :: IO ()+main = putStrLn "Hello, World!"
+ tests/1_io/basic/IORef.expected.stdout view
@@ -0,0 +1,1 @@+xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+ tests/1_io/basic/IORef.hs view
@@ -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')+
+ tests/1_io/basic/enum.expected.stdout view
@@ -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]
+ tests/1_io/basic/enum.hs view
@@ -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 .. ]++
+ tests/1_io/basic/fastest_fib.expected.stdout view
@@ -0,0 +1,11 @@+17711+47+17711+17711+17711+17711+47+17711+17711+17711+17711
+ tests/1_io/basic/fastest_fib.hs view
@@ -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)
+ tests/2_language/Bounds.expected.stdout view
@@ -0,0 +1,8 @@+-128+127+-32768+32767+-2147483648+2147483647+-9223372036854775808+9223372036854775807
+ tests/2_language/Bounds.hs view
@@ -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)
+ tests/2_language/CPP.expected.stdout view
@@ -0,0 +1,1 @@+in lhc
+ tests/2_language/CPP.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}++#ifdef __LHC__+main = putStrLn "in lhc"+#else+main = putStrLn "not in lhc"+#endif
+ tests/2_language/Defaulting.expected.stdout view
@@ -0,0 +1,2 @@+4611686018427387904+3.141592653589793
+ tests/2_language/Defaulting.hs view
@@ -0,0 +1,6 @@+x = 2^62+y = pi++main :: IO ()+main = do print x+          print y
+ tests/2_language/EnumEnum.expected.stdout view
@@ -0,0 +1,1 @@+[LT,EQ,GT]
+ tests/2_language/EnumEnum.hs view
@@ -0,0 +1,3 @@++main :: IO ()+main = print [LT ..]
+ tests/2_language/IntEnum.expected.stdout view
@@ -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]
+ tests/2_language/IntEnum.hs view
@@ -0,0 +1,3 @@+import Data.Int+main = do print . take 0x101 $ [0xffffff,0x1ffffff :: Int32 ..]+
+ tests/2_language/IrrefutableLambda.expected.stdout view
@@ -0,0 +1,1 @@+Hi!
+ tests/2_language/IrrefutableLambda.hs view
@@ -0,0 +1,1 @@+main = (\ ~(a,b) -> putStrLn "Hi!") undefined
+ tests/2_language/KindInference.expected.stdout view
+ tests/2_language/KindInference.hs view
@@ -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 ()
+ tests/2_language/Kleisli.expected.stdout view
+ tests/2_language/Kleisli.hs view
@@ -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) ()
+ tests/2_language/Laziness.expected.stdout view
@@ -0,0 +1,1 @@+()
+ tests/2_language/Laziness.hs view
@@ -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))
+ tests/2_language/NoMonomorphism.expected.stdout view
@@ -0,0 +1,3 @@+9+15.6+2.8957571600107794e-36
+ tests/2_language/NoMonomorphism.hs view
@@ -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))+
+ tests/2_language/PureInteger.expected.stdout view
@@ -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]
+ tests/2_language/PureInteger.hs view
@@ -0,0 +1,2506 @@+--LICENSE: BSD3 (or also similar, like GHC, etc.)+--INITIAL AUTHOR: Isaac Dupree <id@isaac.cedarswampstudios.org>+--+-- 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 <http://www.haskell.org/ghc/docs/+                latest/html/libraries/base/Prelude.html#t%3AInteger>+  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{-<smallBase-} -> 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` (<smallBase)+ - is specially optimized anyway+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+-}+--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{-<intSmallBase-} -> 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
+ tests/3_shootout/BinaryTrees.args view
@@ -0,0 +1,1 @@+12
+ tests/3_shootout/BinaryTrees.expected.stdout view
@@ -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
+ tests/3_shootout/BinaryTrees.hs view
@@ -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
+ tests/3_shootout/Mandelbrot.args view
@@ -0,0 +1,1 @@+1000
+ tests/3_shootout/Mandelbrot.expected.stdout view
binary file changed (absent → 125013 bytes)
+ tests/3_shootout/Mandelbrot.hs view
@@ -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
+ tests/3_shootout/Mandelbrot.mustfail view
+ tests/3_shootout/PartialSums.args view
@@ -0,0 +1,1 @@+250
+ tests/3_shootout/PartialSums.expected.stdout view
@@ -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
+ tests/3_shootout/PartialSums.hs view
@@ -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
+ tests/3_shootout/PartialSums.mustfail view
+ tests/3_shootout/SumFile.expected.stdout view
@@ -0,0 +1,1 @@+12
+ tests/3_shootout/SumFile.hs view
@@ -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'
+ tests/3_shootout/SumFile.stdin view
@@ -0,0 +1,3 @@+3+4+5
+ tests/9_nofib/digits-of-e1.expected.stdout view
@@ -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]
+ tests/9_nofib/digits-of-e1.hs view
@@ -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)++
+ tests/9_nofib/spectral/calendar/Calendar.args view
@@ -0,0 +1,1 @@+2034
+ tests/9_nofib/spectral/calendar/Calendar.expected.stdout view
@@ -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                    +                                                                           
+ tests/9_nofib/spectral/calendar/Calendar.hs view
@@ -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<d  = ["   "]+                              | otherwise    = [rjustify 3 (show d)]++-- The original B+W calendar:++calendar :: Int -> 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
+ tests/9_nofib/spectral/primes/Primes.expected.stdout view
@@ -0,0 +1,1 @@+1229
+ tests/9_nofib/spectral/primes/Primes.hs view
@@ -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)
+ tests/UnitTests.hs view
@@ -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)+
+ tests/bugs/Exceptions1.expected.stdout view
@@ -0,0 +1,1 @@+
+ tests/bugs/Exceptions1.hs view
@@ -0,0 +1,7 @@+module Main where++import Control.Exception+import Prelude hiding (catch)++main :: IO ()+main = (error "Catch me!" `seq` return ()) `catch` \_ -> return ()
+ tests/bugs/Exceptions1.mustfail view
+ tests/bugs/ImportZeal.expected.stdout view
@@ -0,0 +1,1 @@+{True->False;False->True}
+ tests/bugs/ImportZeal.hs view
@@ -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 of depth-bounded values> -----------------++-- 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]++------------------- <methods for type enumeration> ------------------++-- 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)++---------------- <properties and their evaluation> ------------------++-- 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))++--------------------- <top-level test drivers> ----------------------++-- 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
+ tests/bugs/Parsing1.expected.stdout view
+ tests/bugs/Parsing1.hs view
@@ -0,0 +1,6 @@++x :: Int+x = 0;++main :: IO ()+main = return ()
+ tests/bugs/Qualify1.expected.stdout view
+ tests/bugs/Qualify1.hs view
@@ -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 ()+
+ tests/bugs/RayT.args view
@@ -0,0 +1,1 @@+2 100
+ tests/bugs/RayT.expected.stdout view
binary file changed (absent → 10016 bytes)
+ tests/bugs/RayT.hs view
@@ -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
+ tests/bugs/RayT.mustfail view
+ tests/bugs/Recursive2.expected.stdout view
+ tests/bugs/Recursive2.hs view
@@ -0,0 +1,6 @@++a = b+b = a++main :: IO ()+main = return ()
+ tests/bugs/UnpackedPoly.expected.stdout view
@@ -0,0 +1,1 @@+Bar (Foo ["Hi!"])
+ tests/bugs/UnpackedPoly.hs view
@@ -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!"]))