diff --git a/.gitignore b/.gitignore index 795e31a..42348b7 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ -**/.stack-work/ +dist-newstyle +.vscode diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..eedc150 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,4 @@ + +[submodule "external-stg-interpreter/souffle"] + path = external-stg-interpreter/souffle + url = https://github.com/souffle-lang/souffle diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..57910f7 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,32 @@ +# These are just too annoying +- ignore: { name: Redundant do } +- ignore: { name: Redundant bracket } +- ignore: { name: Redundant lambda } +- ignore: { name: Redundant $ } +- ignore: { name: Redundant flip } +- ignore: { name: Redundant <$> } +- ignore: { name: Redundant pure } +- ignore: { name: Move brackets to avoid $ } +- ignore: { name: Use tuple-section } +- ignore: { name: Avoid lambda using `infix` } + +# Losing variable names can be not-nice +- ignore: { name: Eta reduce } +- ignore: { name: Avoid lambda } + +# Humans know better +- ignore: { name: Use camelCase } +- ignore: { name: Use const } +- ignore: { name: Use section } +- ignore: { name: Use if } +- ignore: { name: Use notElem } +- ignore: { name: Use fromMaybe } +- ignore: { name: Use maybe } +- ignore: { name: Use fmap } +- ignore: { name: Use foldl } +- ignore: { name: "Use :" } +- ignore: { name: Use ++ } +- ignore: { name: Use || } +- ignore: { name: Use && } +- ignore: { name: 'Use ?~' } +- ignore: { name: Use <$> } \ No newline at end of file diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..85c74fe --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,409 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + # + # # When to break the "where". + # # Possible values: + # # - exports: only break when there is an explicit export list. + # # - single: only break when the export list counts more than one export. + # # - inline: only break when the export list is too long. This is + # # determined by the `columns` setting. Not applicable when the export + # # list contains comments as newlines will be required. + # # - always: always break before the "where". + # break_where: exports + # + # # Where to put open bracket + # # Possible values: + # # - same_line: put open bracket on the same line as the module name, before the + # # comment of the module + # # - next_line: put open bracket on the next line, after module comment + # open_bracket: next_line + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + # - records: + # # How to format equals sign between type constructor and data constructor. + # # Possible values: + # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + # equals: "indent 2" + # + # # How to format first field of each record constructor. + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # first_field: "indent 2" + # + # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + # field_comment: 2 + # + # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + # via: "indent 2" + # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # + # # Whether or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Post qualify option moves any qualifies found in import declarations + # to the end of the declaration. This also adjust padding for any + # unqualified import declarations. + # + # - true: Qualified as is moved to the end of the + # declaration. + # + # > import Data.Bar + # > import Data.Foo qualified as F + # + # - false: Qualified remains in the default location and unqualified + # imports are padded to align with qualified imports. + # + # > import Data.Bar + # > import qualified Data.Foo as F + # + # Default: false + post_qualify: false + + # Automatically group imports based on their module names, with + # a blank line separating each group. Groups are ordered in + # alphabetical order. + # + # By default, this groups by the first part of each module's + # name (Control.* will be grouped together, Data.*... etc), but + # this can be configured with the group_patterns setting. + # + # When enabled, this rewrites existing blank lines and groups. + # + # - true: Group imports by the first part of the module name. + # + # > import Control.Applicative + # > import Control.Monad + # > import Control.Monad.MonadError + # > + # > import Data.Functor + # + # - false: Keep import groups as-is (still sorting and + # formatting the imports within each group) + # + # > import Control.Monad + # > import Data.Functor + # > + # > import Control.Applicative + # > import Control.Monad.MonadError + # + # Default: false + group_imports: true + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-# LANGUAGE #-}'. + # + # - vertical_compact: Similar to vertical, but use only one language pragma. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + - tabs: + # Number of spaces to use for each tab. Default: 8, as specified by the + # Haskell report. + spaces: 4 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 120 # null + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true \ No newline at end of file diff --git a/README.md b/README.md index 8b03836..4815629 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ The project consists of GHC **wpc-plugin** and the corresponding **External STG IR** and **tooling**. -The wpc-plugin is a compiler plugin for GHC 9.6 or newer. It exports the STG IR `(.modpak)` for the compiled modules and linker metadata (`.ghc_stgapp`) at application link time. +The wpc-plugin is a compiler plugin for GHC 9.12.2. It exports the STG IR `(.modpak)` for the compiled modules and linker metadata (`.ghc_stgapp`) at application link time. @@ -33,7 +33,7 @@ The wpc-plugin is a compiler plugin for GHC 9.6 or newer. It exports the STG IR ## Build #### external stg tooling ``` - stack install + cabal install ext-stg stgapp mkfullpak ext-stg-interpreter ``` #### `wpc-plugin` @@ -41,11 +41,9 @@ The wpc-plugin is a compiler plugin for GHC 9.6 or newer. It exports the STG IR ``` cabal install zip-cmd ``` -2. Compile the `wpc-plugin` - The `wpc-plugin` has a speparate `stack.yaml` because it uses the plugin API of `GHC 9.6.1`. +2. Compile the `wpc-plugin` it uses the plugin API of `GHC 9.12.2`. ``` - cd wpc-plugin - stack build + cabal build wpc-plugin ``` 3. Find the built `libwpc-plugin.[so|dylib|dll]` ``` @@ -53,7 +51,7 @@ The wpc-plugin is a compiler plugin for GHC 9.6 or newer. It exports the STG IR ``` ## Usage -It is required to use GHC 9.6.1. +It is required to use GHC 9.12.2. #### cabal Add the following lines to your project's `cabal.project`: @@ -64,16 +62,6 @@ package * -fplugin-library=PATH_TO/libwpc-plugin.so;wpc-plugin-unit;WPC.Plugin;[] ``` -#### stack -Add the following lines to your project's `stack.yaml`: -``` -apply-ghc-options: everything -ghc-options: - "$everything": - -fplugin-trustworthy - -fplugin-library=PATH_TO/libwpc-plugin.so;wpc-plugin-unit;WPC.Plugin;[] -``` - ## TODO **Ext-STG IR** - export IdInfo (without it `gen-exe` compiles -O0 executables) diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..56e9a2c --- /dev/null +++ b/cabal.project @@ -0,0 +1,18 @@ + +packages: + external-stg-syntax + external-stg + external-stg-interpreter + wpc-plugin + -- external-stg-compiler + -- lambda + +source-repository-package + type: git + location: https://github.com/david-christiansen/final-pretty-printer.git + tag: 048e8fa2d8b2b7a6f9e4e209db4f67361321eec8 + +source-repository-package + type: git + location: https://github.com/zlonast/souffle-haskell.git + tag: d6074faaf921a55e12bda65c8dcd40aca001b46b diff --git a/external-stg-compiler/app/gen-obj.hs b/external-stg-compiler/app/gen-obj.hs index 3002431..ef91356 100644 --- a/external-stg-compiler/app/gen-obj.hs +++ b/external-stg-compiler/app/gen-obj.hs @@ -42,7 +42,7 @@ main = runGhc (Just libdir) $ do let StgModule{..} = toStg strippedExtModule oName = modpakName ++ ".o" --liftIO $ putStrLn $ "compiling " ++ oName - --putStrLn $ unlines $ map show stgIdUniqueMap + --putStrLn $ unlines $ fmap show stgIdUniqueMap -- HINT: the stubs are compiled at link time compileToObjectM cg stgUnitId stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName diff --git a/external-stg-compiler/external-stg-compiler.cabal b/external-stg-compiler/external-stg-compiler.cabal index b452c26..63854f6 100644 --- a/external-stg-compiler/external-stg-compiler.cabal +++ b/external-stg-compiler/external-stg-compiler.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.14 name: external-stg-compiler version: 0.1.0.0 -- synopsis: @@ -40,7 +40,13 @@ library , souffle-haskell , time - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards cpp-options: -DEXTERNAL_STG_COMPILER_PACKAGE include-dirs: cbits @@ -69,7 +75,13 @@ executable gen-exe , containers , bytestring - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards executable gen-obj hs-source-dirs: app @@ -80,7 +92,13 @@ executable gen-obj , ghc-paths , external-stg , external-stg-compiler - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards executable gen-exe2 hs-source-dirs: app @@ -97,7 +115,13 @@ executable gen-exe2 , filepath , bytestring - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards executable gen-obj2 hs-source-dirs: app @@ -111,7 +135,13 @@ executable gen-obj2 , bytestring , external-stg , external-stg-compiler - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards executable show-ghc-stg hs-source-dirs: app @@ -123,7 +153,13 @@ executable show-ghc-stg , external-stg , external-stg-compiler , filepath - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards executable dce-fullpak hs-source-dirs: app @@ -139,4 +175,10 @@ executable dce-fullpak , bytestring , zip - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards diff --git a/external-stg-compiler/hie.yaml b/external-stg-compiler/hie.yaml new file mode 100644 index 0000000..586d47f --- /dev/null +++ b/external-stg-compiler/hie.yaml @@ -0,0 +1,22 @@ +cradle: + cabal: + - path: "lib" + component: "lib:external-stg-compiler" + + - path: "app/gen-exe.hs" + component: "external-stg-compiler:exe:gen-exe" + + - path: "app/gen-obj.hs" + component: "external-stg-compiler:exe:gen-obj" + + - path: "app/gen-exe2.hs" + component: "external-stg-compiler:exe:gen-exe2" + + - path: "app/gen-obj2.hs" + component: "external-stg-compiler:exe:gen-obj2" + + - path: "app/show-ghc-stg.hs" + component: "external-stg-compiler:exe:show-ghc-stg" + + - path: "app/dce-fullpak.hs" + component: "external-stg-compiler:exe:dce-fullpak" diff --git a/external-stg-compiler/lib/Stg/DeadFunctionElimination/Analysis.hs b/external-stg-compiler/lib/Stg/DeadFunctionElimination/Analysis.hs index 7f3c734..8cd1191 100644 --- a/external-stg-compiler/lib/Stg/DeadFunctionElimination/Analysis.hs +++ b/external-stg-compiler/lib/Stg/DeadFunctionElimination/Analysis.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, TemplateHaskell #-} -{-# LANGUAGE RecordWildCards, LambdaCase, TupleSections, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + module Stg.DeadFunctionElimination.Analysis where import Control.Monad.IO.Class diff --git a/external-stg-compiler/lib/Stg/DeadFunctionElimination/Facts.hs b/external-stg-compiler/lib/Stg/DeadFunctionElimination/Facts.hs index a1780e9..00fe282 100644 --- a/external-stg-compiler/lib/Stg/DeadFunctionElimination/Facts.hs +++ b/external-stg-compiler/lib/Stg/DeadFunctionElimination/Facts.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, TupleSections, OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} + module Stg.DeadFunctionElimination.Facts where import Data.Map (Map) @@ -29,7 +30,7 @@ writeDfeFacts prefixPath Module{..} = do getTopBinders :: TopBinding -> [Binder] getTopBinders = \case StgTopLifted (StgNonRec b _) -> [b] - StgTopLifted (StgRec bs) -> map fst bs + StgTopLifted (StgRec bs) -> fmap fst bs StgTopStringLit b _ -> [b] topBinders :: [Binder] @@ -89,7 +90,7 @@ writeDfeFacts prefixPath Module{..} = do visitBinding :: Name -> Binding -> IO () visitBinding fun = \case StgNonRec _ rhs -> visitRhs fun rhs - StgRec l -> mapM_ (visitRhs fun) $ map snd l + StgRec l -> mapM_ (visitRhs fun) $ fmap snd l visitRhs :: Name -> Rhs -> IO () visitRhs fun = \case diff --git a/external-stg-compiler/lib/Stg/DeadFunctionElimination/StripModule.hs b/external-stg-compiler/lib/Stg/DeadFunctionElimination/StripModule.hs index dc74627..275b189 100644 --- a/external-stg-compiler/lib/Stg/DeadFunctionElimination/StripModule.hs +++ b/external-stg-compiler/lib/Stg/DeadFunctionElimination/StripModule.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, TupleSections, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + module Stg.DeadFunctionElimination.StripModule where import Data.Maybe @@ -38,7 +39,7 @@ stripDeadParts stgappName mod = do | otherwise -> Nothing -- TODO: strip stgModuleTyCons - pure mod {moduleTopBindings = catMaybes $ map dropDeadBinding $ moduleTopBindings mod} + pure mod {moduleTopBindings = mapMaybe dropDeadBinding (moduleTopBindings mod)} tryStripDeadParts :: FilePath -> Module -> IO Module tryStripDeadParts stgappName mod = do diff --git a/external-stg-compiler/lib/Stg/GHC/Backend.hs b/external-stg-compiler/lib/Stg/GHC/Backend.hs index ec5ec02..c533ab8 100644 --- a/external-stg-compiler/lib/Stg/GHC/Backend.hs +++ b/external-stg-compiler/lib/Stg/GHC/Backend.hs @@ -1,7 +1,7 @@ module Stg.GHC.Backend where -- Compiler -import GHC +import GHC hiding (Backend) import GHC.Paths ( libdir ) import GHC.Platform ( platformOS, osSubsectionsViaSymbols ) import GHC.Driver.CodeOutput @@ -33,7 +33,7 @@ import GHC.Cmm import GHC.Cmm.Info (cmmToRawCmm ) import GHC.StgToCmm (codeGen) import GHC.Types.Unique.Supply ( mkSplitUniqSupply, initUs_ ) -import GHC.StgToCmm.Types (CgInfos (..)) +import GHC.StgToCmm.Types (CmmCgInfos (..)) import Control.Monad.Trans import Control.Monad @@ -46,6 +46,9 @@ import qualified Stg.Syntax as C import Data.List (isSuffixOf) import System.FilePath +import GHC.ForeignSrcLang +import GHC.Types.ForeignStubs +import GHC.Types.HpcInfo ------------------------------------------------------------------------------- -- Module @@ -103,7 +106,7 @@ compileToObjectM backend unitId modName stubs tyCons topBinds_simple outputName -- Compile dflags <- getSessionDynFlags pkgs <- setSessionDynFlags $ - dflags { hscTarget = target, ghcLink = NoLink } + dflags { targetPlatform = target, ghcLink = NoLink } `gopt_set` Opt_KeepSFiles `gopt_set` Opt_KeepLlvmFiles -- `dopt_set` Opt_D_dump_cmm @@ -156,7 +159,6 @@ type CollectedCCs = ( [CostCentre] -- local cost-centres that need to be decl'd , [CostCentreStack] -- pre-defined "singleton" cost centre stacks ) --} let ccs = emptyCollectedCCs :: CollectedCCs hpc = emptyHpcInfo False @@ -169,18 +171,18 @@ type CollectedCCs NCG -> (HscAsm, As False) -- WORKAROUND: filter out rts includes - let incPathsFixed = [p | p <- incPaths, not (isSuffixOf "rts-1.0/include" p)] + let incPathsFixed = [p | p <- incPaths, not ("rts-1.0/include" `isSuffixOf` p)] -- Compile & Link dflags <- getSessionDynFlags setSessionDynFlags $ (if noHsMain then flip gopt_set Opt_NoHsMain else id) $ dflags - { hscTarget = target - , ghcLink = LinkBinary - , libraryPaths = libraryPaths dflags ++ libPaths - , ldInputs = ldInputs dflags ++ map Option ldOpts - , includePaths = addQuoteInclude (includePaths dflags) incPathsFixed + { targetPlatform = target + , ghcLink = LinkBinary + , libraryPaths = libraryPaths dflags ++ libPaths + , ldInputs = ldInputs dflags ++ fmap Option ldOpts + , includePaths = addQuoteInclude (includePaths dflags) incPathsFixed } `gopt_set` Opt_KeepSFiles `gopt_set` Opt_KeepLlvmFiles @@ -198,7 +200,7 @@ type CollectedCCs let libSet = Set.fromList ["rts"] -- "rts", "ghc-prim-cbits", "base-cbits", "integer-gmp-cbits"] dflags <- getSessionDynFlags - let ignored_pkgs = [IgnorePackage p | p <- map (unpackFS . unitIdFS) pkgs, Set.notMember p libSet] + let ignored_pkgs = [IgnorePackage p | p <- fmap (unpackFS . unitIdFS) pkgs, Set.notMember p libSet] my_pkgs = [ExposePackage p (PackageArg p) (ModRenaming True []) | p <- Set.toList libSet] setSessionDynFlags $ dflags { ignorePackageFlags = ignored_pkgs, packageFlags = my_pkgs } dflags <- getSessionDynFlags @@ -225,7 +227,7 @@ newGen :: DynFlags -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos) + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CmmCgInfos) newGen dflags hsc_env output_filename this_mod foreign_stubs data_tycons cost_centre_info stg_binds hpc_info = do -- TODO: add these to parameters let location = ModLocation @@ -244,7 +246,7 @@ newGen dflags hsc_env output_filename this_mod foreign_stubs data_tycons cost_ce ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - lookupHook (\x -> cmmToRawCmmHook x) + lookupHook cmmToRawCmmHook (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms let dump a = do diff --git a/external-stg-compiler/lib/Stg/GHC/Convert_9_2.hs b/external-stg-compiler/lib/Stg/GHC/Convert_9_2.hs index 2d2058a..0da1f58 100644 --- a/external-stg-compiler/lib/Stg/GHC/Convert_9_2.hs +++ b/external-stg-compiler/lib/Stg/GHC/Convert_9_2.hs @@ -560,7 +560,7 @@ cvtTopBindsAndStubs binds stubs decls = do s <- cvtForeignStubs stubs decls let stgTopIds = concatMap topBindIds binds - topKeys = IntSet.fromList $ map uniqueKey stgTopIds + topKeys = IntSet.fromList $ fmap uniqueKey stgTopIds Env{..} <- get extItems <- sequence [mkExternalName e | (k,e) <- IntMap.toList envExternalIds, IntSet.notMember k topKeys] pure (b, s, groupByUnitIdAndModule extItems) @@ -638,11 +638,11 @@ cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls foreign stgTopIds = concatMap topBindIds binds modName = cvtModuleName modName' unitId = cvtUnitId unit' - tyCons = groupByUnitIdAndModule . map mkTyCon $ IntMap.elems envTyCons + tyCons = groupByUnitIdAndModule . fmap mkTyCon $ IntMap.elems envTyCons -- calculate dependencies - externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ map (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] - dependencies = map (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons + externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ fmap (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] + dependencies = fmap (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons -- utils @@ -661,7 +661,7 @@ mkTyCon tc = (cvtUnitIdAndModuleName $ GHC.nameModule n, b) where b = STyCon { stcName = cvtOccName $ GHC.getOccName n , stcId = TyConId . cvtUnique . GHC.getUnique $ n - , stcDataCons = map mkSDataCon . sortDataCons $ GHC.tyConDataCons tc + , stcDataCons = fmap mkSDataCon . sortDataCons $ GHC.tyConDataCons tc , stcDefLoc = cvtSrcSpan $ GHC.nameSrcSpan n } sortDataCons l = IntMap.elems $ IntMap.fromList [(GHC.dataConTag dc, dc) | dc <- l] @@ -697,5 +697,5 @@ mkSDataCon dc = SDataCon topBindIds :: GHC.StgTopBinding -> [GHC.Id] topBindIds = \case GHC.StgTopLifted (GHC.StgNonRec b _) -> [b] - GHC.StgTopLifted (GHC.StgRec bs) -> map fst bs + GHC.StgTopLifted (GHC.StgRec bs) -> fmap fst bs GHC.StgTopStringLit b _ -> [b] diff --git a/external-stg-compiler/lib/Stg/GHC/Convert_9_4.hs b/external-stg-compiler/lib/Stg/GHC/Convert_9_4.hs index 03e35e7..1a852f2 100644 --- a/external-stg-compiler/lib/Stg/GHC/Convert_9_4.hs +++ b/external-stg-compiler/lib/Stg/GHC/Convert_9_4.hs @@ -412,7 +412,7 @@ cvtIdDetails i = case GHC.idDetails i of GHC.DFunId{} -> pure DFunId GHC.CoVarId{} -> pure CoVarId GHC.JoinId ar m -> pure $ JoinId ar (fmap (map cvtCbvMark) m) - GHC.WorkerLikeId l -> pure $ WorkerLikeId $ map cvtCbvMark l + GHC.WorkerLikeId l -> pure $ WorkerLikeId $ fmap cvtCbvMark l cvtScope :: GHC.Id -> Scope cvtScope i @@ -574,7 +574,7 @@ cvtTopBindsAndStubs binds stubs decls = do s <- cvtForeignStubs stubs decls let stgTopIds = concatMap topBindIds binds - topKeys = IntSet.fromList $ map uniqueKey stgTopIds + topKeys = IntSet.fromList $ fmap uniqueKey stgTopIds Env{..} <- get extItems <- sequence [mkExternalName e | (k,e) <- IntMap.toList envExternalIds, IntSet.notMember k topKeys] pure (b, s, groupByUnitIdAndModule extItems) @@ -669,11 +669,11 @@ cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls foreign stgTopIds = concatMap topBindIds binds modName = cvtModuleName modName' unitId = cvtUnitId unit' - tyCons = groupByUnitIdAndModule . map mkTyCon $ IntMap.elems envTyCons + tyCons = groupByUnitIdAndModule . fmap mkTyCon $ IntMap.elems envTyCons -- calculate dependencies - externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ map (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] - dependencies = map (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons + externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ fmap (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] + dependencies = fmap (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons -- utils @@ -692,7 +692,7 @@ mkTyCon tc = (cvtUnitIdAndModuleName $ GHC.nameModule n, b) where b = STyCon { stcName = cvtOccName $ GHC.getOccName n , stcId = TyConId . cvtUnique . GHC.getUnique $ n - , stcDataCons = map mkSDataCon . sortDataCons $ GHC.tyConDataCons tc + , stcDataCons = fmap mkSDataCon . sortDataCons $ GHC.tyConDataCons tc , stcDefLoc = cvtSrcSpan $ GHC.nameSrcSpan n } sortDataCons l = IntMap.elems $ IntMap.fromList [(GHC.dataConTag dc, dc) | dc <- l] @@ -728,5 +728,5 @@ mkSDataCon dc = SDataCon topBindIds :: GHC.CgStgTopBinding -> [GHC.Id] topBindIds = \case GHC.StgTopLifted (GHC.StgNonRec b _) -> [b] - GHC.StgTopLifted (GHC.StgRec bs) -> map fst bs + GHC.StgTopLifted (GHC.StgRec bs) -> fmap fst bs GHC.StgTopStringLit b _ -> [b] diff --git a/external-stg-compiler/lib/Stg/GHC/Convert_9_6.hs b/external-stg-compiler/lib/Stg/GHC/Convert_9_6.hs index 6086bf4..1774ecb 100644 --- a/external-stg-compiler/lib/Stg/GHC/Convert_9_6.hs +++ b/external-stg-compiler/lib/Stg/GHC/Convert_9_6.hs @@ -413,7 +413,7 @@ cvtIdDetails i = case GHC.idDetails i of GHC.DFunId{} -> pure DFunId GHC.CoVarId{} -> pure CoVarId GHC.JoinId ar m -> pure $ JoinId ar (fmap (map cvtCbvMark) m) - GHC.WorkerLikeId l -> pure $ WorkerLikeId $ map cvtCbvMark l + GHC.WorkerLikeId l -> pure $ WorkerLikeId $ fmap cvtCbvMark l cvtScope :: GHC.Id -> Scope cvtScope i @@ -576,7 +576,7 @@ cvtTopBindsAndStubs binds stubs decls = do s <- cvtForeignStubs stubs decls let stgTopIds = concatMap topBindIds binds - topKeys = IntSet.fromList $ map uniqueKey stgTopIds + topKeys = IntSet.fromList $ fmap uniqueKey stgTopIds Env{..} <- get extItems <- sequence [mkExternalName e | (k,e) <- IntMap.toList envExternalIds, IntSet.notMember k topKeys] pure (b, s, groupByUnitIdAndModule extItems) @@ -673,11 +673,11 @@ cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls foreign stgTopIds = concatMap topBindIds binds modName = cvtModuleName modName' unitId = cvtUnitId unit' - tyCons = groupByUnitIdAndModule . map mkTyCon $ IntMap.elems envTyCons + tyCons = groupByUnitIdAndModule . fmap mkTyCon $ IntMap.elems envTyCons -- calculate dependencies - externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ map (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] - dependencies = map (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons + externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ fmap (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] + dependencies = fmap (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons -- utils @@ -696,7 +696,7 @@ mkTyCon tc = (cvtUnitIdAndModuleName $ GHC.nameModule n, b) where b = STyCon { stcName = cvtOccName $ GHC.getOccName n , stcId = TyConId . cvtUnique . GHC.getUnique $ n - , stcDataCons = map mkSDataCon . sortDataCons $ GHC.tyConDataCons tc + , stcDataCons = fmap mkSDataCon . sortDataCons $ GHC.tyConDataCons tc , stcDefLoc = cvtSrcSpan $ GHC.nameSrcSpan n } sortDataCons l = IntMap.elems $ IntMap.fromList [(GHC.dataConTag dc, dc) | dc <- l] @@ -732,5 +732,5 @@ mkSDataCon dc = SDataCon topBindIds :: GHC.CgStgTopBinding -> [GHC.Id] topBindIds = \case GHC.StgTopLifted (GHC.StgNonRec b _) -> [b] - GHC.StgTopLifted (GHC.StgRec bs) -> map fst bs + GHC.StgTopLifted (GHC.StgRec bs) -> fmap fst bs GHC.StgTopStringLit b _ -> [b] diff --git a/external-stg-compiler/lib/Stg/GHC/ToStg.hs b/external-stg-compiler/lib/Stg/GHC/ToStg.hs index aefc6d8..3aaf421 100644 --- a/external-stg-compiler/lib/Stg/GHC/ToStg.hs +++ b/external-stg-compiler/lib/Stg/GHC/ToStg.hs @@ -70,7 +70,7 @@ simpleDataCon tc name args tag workerName = dataCon where dataCon = mkDataCon name False (error "TyConRepName") [] [] [] [] [] [] [] - [tymult t | t <- map primRepToType args] ({-error "Original result type"-}primRepToType LiftedRep) (error "RuntimeRepInfo") + [tymult t | t <- fmap primRepToType args] ({-error "Original result type"-}primRepToType LiftedRep) (error "RuntimeRepInfo") tc tag [] workerId NoDataConRep workerId = mkDataConWorkId workerName dataCon @@ -144,12 +144,12 @@ setAlgTyCons tyCons = do dataCons = [(edc, simpleDataCon tyCon conName (getConRep dcRep) tag workerName) | ((conName, workerName), edc@Ext.DataCon{..}, tag) <- zip3 dcNames tcDataCons [1..]] tyCon :: TyCon - tyCon = simpleTyCon tyConName $ map snd dataCons + tyCon = simpleTyCon tyConName $ fmap snd dataCons getConRep :: Ext.DataConRep -> [PrimRep] getConRep = \case Ext.UnboxedTupleCon{} -> error $ "UnboxedTupleCon in alg TyCon: " ++ show (tcUnitId, tcModule, tcName) - Ext.AlgDataCon l -> map cvtPrimRep l + Ext.AlgDataCon l -> fmap cvtPrimRep l modify' $ \env@Env{..} -> env { envADTTyConMap = Map.insert tcId tyCon envADTTyConMap , envDataConMap = foldr (\(k, v) m -> Map.insert k v m) envDataConMap [(dcId, dc) | (Ext.DataCon{..}, dc) <- dataCons] @@ -284,7 +284,7 @@ cvtPrimRepType :: Ext.Type -> Type cvtPrimRepType = \case Ext.SingleValue Ext.VoidRep -> mkTupleTy Unboxed [] Ext.SingleValue r -> primRepToType $ cvtPrimRep r - Ext.UnboxedTuple l -> mkTupleTy Unboxed $ map (primRepToType . cvtPrimRep) l + Ext.UnboxedTuple l -> mkTupleTy Unboxed $ fmap (primRepToType . cvtPrimRep) l Ext.PolymorphicRep -> mkInfForAllTy runtimeRep2TyVar $ mkSpecForAllTys [openBetaTyVar] $ mkTyVarTy openBetaTyVar diff --git a/external-stg-interpreter/README.md b/external-stg-interpreter/README.md index 15ac304..ebcdb2b 100644 --- a/external-stg-interpreter/README.md +++ b/external-stg-interpreter/README.md @@ -16,7 +16,7 @@ The interpreter was tested only on Linux. ``` cd ghc-whole-program-compiler-project/external-stg-interpreter - stack install + cabal install ``` ## Example Usage diff --git a/external-stg-interpreter/Setup.hs b/external-stg-interpreter/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/external-stg-interpreter/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/external-stg-interpreter/app/ExtStgInterpreter.hs b/external-stg-interpreter/app/ExtStgInterpreter.hs index 500eb55..3ae9a11 100644 --- a/external-stg-interpreter/app/ExtStgInterpreter.hs +++ b/external-stg-interpreter/app/ExtStgInterpreter.hs @@ -1,15 +1,30 @@ -{-# LANGUAGE LambdaCase, RecordWildCards #-} - import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi -import Control.Concurrent.MVar +import Control.Concurrent.MVar (newEmptyMVar) + +import Data.Bool (Bool (..)) +import Data.Either (Either (..)) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.List (dropWhile, (++)) +import Data.Maybe (Maybe (..)) +import Data.Monoid (Monoid (..), (<>)) +import Data.String (String, words) + +import GHC.Err (error) + +import Options.Applicative (Alternative (..), Applicative (..), Parser, argument, + execParser, help, helper, info, long, metavar, optional, short, + str, strOption, switch, value, (<$>), (<**>)) -import Options.Applicative -import Data.Semigroup ((<>)) import qualified ShellWords -import Stg.Interpreter.Debugger.UI -import Stg.Interpreter.Base -import Stg.Interpreter +import Stg.Interpreter (loadAndRunProgram) +import Stg.Interpreter.Base (DebugSettings (..), DebugState (..), DebuggerChan (..), + defaultDebugSettings) +import Stg.Interpreter.Debugger.UI (debugProgram) + +import System.IO (FilePath, IO, readFile) + data StgIOpts = StgIOpts @@ -50,10 +65,10 @@ main = do argsFromFile <- case appArgsFile of Nothing -> pure [] Just fname -> do - str <- readFile fname - case ShellWords.parse str of - Left err -> error err - Right l -> pure l + str' <- readFile fname + case ShellWords.parse str' of + Left err -> error err + Right l -> pure l let appArgs0 = argsFromFile ++ words appArgs1 ++ appArgs2 ++ appArgs3 appArgs = if ignoreRtsArgs then dropRtsOpts appArgs0 else appArgs0 @@ -76,7 +91,7 @@ main = do False -> loadAndRunProgram isQuiet switchCWD appPath appArgs dbgChan DbgRunProgram doTracing debugSettings dropRtsOpts :: [String] -> [String] -dropRtsOpts [] = [] +dropRtsOpts [] = [] dropRtsOpts ("+RTS" : args) = dropRtsOpts $ dropWhile (/= "-RTS") args dropRtsOpts ("-RTS" : args) = dropRtsOpts args -dropRtsOpts (a : args) = a : dropRtsOpts args +dropRtsOpts (a : args) = a : dropRtsOpts args diff --git a/external-stg-interpreter/app/RunStgiTestsuite.hs b/external-stg-interpreter/app/RunStgiTestsuite.hs index 09d4c02..c49cad0 100644 --- a/external-stg-interpreter/app/RunStgiTestsuite.hs +++ b/external-stg-interpreter/app/RunStgiTestsuite.hs @@ -1,38 +1,58 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings #-} -import Control.Monad -import Data.Containers.ListUtils -import System.Directory -import System.FilePath -import System.FilePath.Find -import System.Process -import Text.Printf - -import Control.Concurrent.Async.Pool -import GHC.Conc (getNumProcessors) -import System.TimeIt -import System.Timeout -import System.Exit -import System.IO -import System.Environment - -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import Text.PrettyPrint.ANSI.Leijen hiding ((), (<$>)) - +import Control.Applicative (Applicative (..), (<$>)) +import Control.Concurrent.Async.Pool (mapTasks, withTaskGroup) +import Control.Monad (Functor (..), Monad (..), forM, mapM) + +import Data.Bool (Bool (..), not, otherwise, (&&), (||)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Containers.ListUtils (nubOrd) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int) +import Data.List (concat, filter, length, null, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), catMaybes, fromJust, fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (String, unlines, unwords) + +import GHC.Conc (getNumProcessors) +import GHC.Float (Double) +import GHC.Num (Num (..)) +import GHC.Real (Fractional (..), fromIntegral) + +import Prettyprinter (Doc, Pretty (..), annotate) +import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color) + +import System.Directory (doesFileExist, getSymbolicLinkTarget, makeAbsolute, pathIsSymbolicLink) +import System.Environment (getArgs) +import System.Exit (ExitCode (..)) +import System.FilePath (FilePath, dropExtension, takeDirectory, takeFileName, (-<.>), ()) +import System.FilePath.Find (always, depth, fileName, find, readLink, (==?), (~~?)) +import System.IO (IO, IOMode (..), putStrLn, readFile, withFile) +import System.Process (CreateProcess (..), StdStream (..), proc, waitForProcess, + withCreateProcess) +import System.TimeIt (timeItNamed) +import System.Timeout (timeout) + +import Text.Printf (printf) +import Text.Read (read) +import Text.Show (Show (..)) + +green :: Doc AnsiStyle -> Doc AnsiStyle +green = annotate (color Green) + +cyan :: Doc AnsiStyle -> Doc AnsiStyle +cyan = annotate (color Cyan) + +red :: Doc AnsiStyle -> Doc AnsiStyle +red = annotate (color Red) {- testsuite compilation / preparation COMPILE TESTS: (PATH=/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin:$PATH make CLEANUP=0 THREADS=12 RUNNABLE_ONLY=1 EXTRA_HC_OPTS='-fPIC') -} -{- -#test_path = '/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/' --} - {- TODO done - save exit code @@ -63,15 +83,15 @@ data TestResult | Error FilePath String | Skip FilePath | Timeout FilePath - deriving Show + deriving stock Show report :: TestResult -> IO TestResult report t = do case t of OK f -> printf "%s %s\n" (show $ green "OK") f - Error f e -> printf "%s %s\n%s\n" (show $ red "ERROR") (show . red $ text f) (show . red $ text e) - Skip f -> printf "%s %s\n" (show $ cyan "SKIP") (show . cyan $ text f) - Timeout f -> printf "%s %s\n" (show $ red "TIMEOUT") (show . red $ text f) + Error f e -> printf "%s %s\n%s\n" (show $ red "ERROR") (show . red $ pretty f) (show . red $ pretty e) + Skip f -> printf "%s %s\n" (show $ cyan "SKIP") (show . cyan $ pretty f) + Timeout f -> printf "%s %s\n" (show $ red "TIMEOUT") (show . red $ pretty f) Fail f (expectedExitCode, exitCode) (expectedStdout, out) (expectedStderr, err) -> do let exitCodeMsg = if expectedExitCode == exitCode then "" else unlines [ " exitcode mismatch" @@ -89,7 +109,7 @@ report t = do , " got : " ++ show err ] msg = unlines $ filter (not . null) [exitCodeMsg, stdoutMsg, stderrMsg] - printf "%s %s\n%s\n" (show $ red "FAIL") (show $ red $ text f) (show $ red $ text msg) + printf "%s %s\n%s\n" (show $ red "FAIL") (show $ red $ pretty f) (show $ red $ pretty msg) pure t runTestProcess :: FilePath -> String -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString) @@ -113,11 +133,11 @@ runTestProcess path cmd args input = do readTestOpts :: FilePath -> IO (Bool, Bool) readTestOpts optsPath = do - opts <- Map.fromList . read <$> readFile optsPath + opts <- Map.fromList @String . read <$> readFile optsPath pure . fromJust $ (,) <$> Map.lookup "ignore_stdout" opts <*> Map.lookup "ignore_stderr" opts runTest :: Set FilePath -> FilePath -> IO TestResult -runTest skipSet stderrPath = do +runTest skipSet' stderrPath = do let stdoutPath = stderrPath -<.> ".stdout" stdinPath = stderrPath -<.> ".stdin" argsPath = stderrPath -<.> ".args" @@ -134,7 +154,7 @@ runTest skipSet stderrPath = do stgApps <- find (depth ==? 0) (fileName ~~? (testName ++ ".*_ghc_stgapp")) testDir case stgApps of [ghcstgappPath] - | Set.member ghcstgappPath skipSet + | Set.member ghcstgappPath skipSet' -> do report $ Skip ghcstgappPath @@ -176,6 +196,7 @@ runTest skipSet stderrPath = do [] -> report $ Error "" $ "missing ghc_stgapp: " ++ testDir testName ++ ".*_ghc_stgapp" l -> report $ Error "" $ "ambiguous ghc_stgapp: " ++ unwords l +main :: IO () main = do scanList <- getArgs >>= \case [] -> pure testPaths @@ -203,8 +224,10 @@ main = do log "SKIP" [() | Skip{} <- result] log "TIMEOUT" [() | Timeout{} <- result] - +{- +testPaths1 :: [String] testPaths1 = ["/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/codeGen/should_run/T18527.run"] +-} testPaths :: [FilePath] testPaths = @@ -255,6 +278,7 @@ testPaths = skipSet :: Set FilePath skipSet = Set.fromList $ [] -- ++ skip_set ++ skip_fail ++ skip_timeout +{- skip_set :: [FilePath] skip_set = -- has stubs @@ -319,7 +343,9 @@ skip_set = , "/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/libraries/base/tests/IO/encoding002.run/encoding002.o_ghc_stgapp" , "/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/libraries/process/tests/T8343.run/T8343.o_ghc_stgapp" ] +-} +{- skip_fail :: [FilePath] skip_fail = [ "/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/codeGen/should_run/cgrun060.run/cgrun060.o_ghc_stgapp" @@ -503,3 +529,4 @@ skip_timeout = , "/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/simplCore/should_run/T5920.run/T5920.o_ghc_stgapp" , "/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/simplCore/should_run/T5997.run/T5997.o_ghc_stgapp" ] +-} diff --git a/external-stg-interpreter/data/cbits.so-script/c b/external-stg-interpreter/data/cbits.so-script/c deleted file mode 100755 index 0a3ee8e..0000000 --- a/external-stg-interpreter/data/cbits.so-script/c +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -set -x -e - -gcc -o libHSbase-4.14.0.0.cbits.so -shared \ - -Wl,--whole-archive `ls ar/*.a` -Wl,--no-whole-archive \ - `ls stub-*.dyn_o/*` \ - `ls cbits-rts.dyn_o/*` \ - -fPIC `ls c-src/*` \ - -lm -lgmp -ltinfo \ - -lGL -lX11 -lXi -lXrandr -lXxf86vm -lXcursor -lXinerama -lpthread diff --git a/external-stg-interpreter/data/cbits.so-script/c-src/fake_rts.c b/external-stg-interpreter/data/cbits.so-script/c-src/fake_rts.c deleted file mode 100644 index 180a81e..0000000 --- a/external-stg-interpreter/data/cbits.so-script/c-src/fake_rts.c +++ /dev/null @@ -1,57 +0,0 @@ -#include -#include - -unsigned int n_capabilities = 1; -int rts_isDynamic(void) { - return 1; -} - -int rts_isProfiled(void) { - return 0; -} - -void blockUserSignals(void) { -} - -void unblockUserSignals(void) { -} - -void startTimer(void) { -} - -void stopTimer(void) { -} - -void debugBelch() { -} - -typedef struct _RTS_FLAGS { -} RTS_FLAGS; - -RTS_FLAGS RtsFlags; - -int keepCAFs; - -void performGC(void) { -} - -void performMajorGC(void) { -} - -int getRTSStatsEnabled( void ) { - return 0;//RtsFlags.GcFlags.giveStats != NO_GC_STATS; -} - -uint32_t enabled_capabilities = 1; - -int *stable_ptr_table = NULL; - -void base_GHCziTopHandler_runIO_closure(){} - -void stg_interp_constr1_entry() {} -void stg_interp_constr2_entry() {} -void stg_interp_constr3_entry() {} -void stg_interp_constr4_entry() {} -void stg_interp_constr5_entry() {} -void stg_interp_constr6_entry() {} -void stg_interp_constr7_entry() {} diff --git a/external-stg-interpreter/data/cbits.so-script/c-src/hack.c b/external-stg-interpreter/data/cbits.so-script/c-src/hack.c deleted file mode 100644 index 2f47e25..0000000 --- a/external-stg-interpreter/data/cbits.so-script/c-src/hack.c +++ /dev/null @@ -1,12 +0,0 @@ -extern void *set_curterm(void *nterm); - -void totally_hack_1324rewewjrkewhrk() { - - set_curterm((void*)0); -} - -#include - -void totally_hack_1324rewewjrkewhrk_2(double x) { - double d = log1p(x); -} diff --git a/external-stg-interpreter/data/cbits.so-script/c-src/hschooks.c b/external-stg-interpreter/data/cbits.so-script/c-src/hschooks.c deleted file mode 100644 index ee61104..0000000 --- a/external-stg-interpreter/data/cbits.so-script/c-src/hschooks.c +++ /dev/null @@ -1,5 +0,0 @@ - -void -initGCStatistics(void) -{ -} diff --git a/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/StgPrimFloat.dyn_o b/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/StgPrimFloat.dyn_o deleted file mode 100644 index 5db1b41..0000000 Binary files a/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/StgPrimFloat.dyn_o and /dev/null differ diff --git a/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/TTY.dyn_o b/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/TTY.dyn_o deleted file mode 100644 index ea18957..0000000 Binary files a/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/TTY.dyn_o and /dev/null differ diff --git a/external-stg-interpreter/data/ghc-rts-base.fullpak b/external-stg-interpreter/data/ghc-rts-base.fullpak deleted file mode 100644 index f197f37..0000000 Binary files a/external-stg-interpreter/data/ghc-rts-base.fullpak and /dev/null differ diff --git a/external-stg-interpreter/data/minigame-strict.fullpak b/external-stg-interpreter/data/minigame-strict.fullpak deleted file mode 100644 index 64669a4..0000000 Binary files a/external-stg-interpreter/data/minigame-strict.fullpak and /dev/null differ diff --git a/external-stg-interpreter/datalog/ext-stg-gc.cpp b/external-stg-interpreter/datalog/ext-stg-gc.cpp index 9e6a014..38e3f61 100644 --- a/external-stg-interpreter/datalog/ext-stg-gc.cpp +++ b/external-stg-interpreter/datalog/ext-stg-gc.cpp @@ -1,757 +1,1385 @@ - +#define SOUFFLE_GENERATOR_VERSION "2.4.1" #include "souffle/CompiledSouffle.h" - -namespace functors { - extern "C" { -} -} - -namespace souffle { -static const RamDomain RAM_BIT_SHIFT_MASK = RAM_DOMAIN_SIZE - 1; -struct t_btree_i__0__1 { -static constexpr Relation::arity_type Arity = 1; -using t_tuple = Tuple; -struct t_comparator_0{ - int operator()(const t_tuple& a, const t_tuple& b) const { - return (ramBitCast(a[0]) < ramBitCast(b[0])) ? -1 : (ramBitCast(a[0]) > ramBitCast(b[0])) ? 1 :(0); - } -bool less(const t_tuple& a, const t_tuple& b) const { - return (ramBitCast(a[0]) < ramBitCast(b[0])); - } -bool equal(const t_tuple& a, const t_tuple& b) const { -return (ramBitCast(a[0]) == ramBitCast(b[0])); - } -}; -using t_ind_0 = btree_set; -t_ind_0 ind_0; -using iterator = t_ind_0::iterator; -struct context { -t_ind_0::operation_hints hints_0_lower; -t_ind_0::operation_hints hints_0_upper; -}; -context createContext() { return context(); } -bool insert(const t_tuple& t) { -context h; -return insert(t, h); -} -bool insert(const t_tuple& t, context& h) { -if (ind_0.insert(t, h.hints_0_lower)) { -return true; -} else return false; -} -bool insert(const RamDomain* ramDomain) { -RamDomain data[1]; -std::copy(ramDomain, ramDomain + 1, data); -const t_tuple& tuple = reinterpret_cast(data); -context h; -return insert(tuple, h); -} -bool insert(RamDomain a0) { -RamDomain data[1] = {a0}; -return insert(data); -} -bool contains(const t_tuple& t, context& h) const { -return ind_0.contains(t, h.hints_0_lower); -} -bool contains(const t_tuple& t) const { -context h; -return contains(t, h); -} -std::size_t size() const { -return ind_0.size(); -} -iterator find(const t_tuple& t, context& h) const { -return ind_0.find(t, h.hints_0_lower); -} -iterator find(const t_tuple& t) const { -context h; -return find(t, h); -} -range lowerUpperRange_0(const t_tuple& /* lower */, const t_tuple& /* upper */, context& /* h */) const { -return range(ind_0.begin(),ind_0.end()); -} -range lowerUpperRange_0(const t_tuple& /* lower */, const t_tuple& /* upper */) const { -return range(ind_0.begin(),ind_0.end()); -} -range lowerUpperRange_1(const t_tuple& lower, const t_tuple& upper, context& h) const { -t_comparator_0 comparator; -int cmp = comparator(lower, upper); -if (cmp == 0) { - auto pos = ind_0.find(lower, h.hints_0_lower); - auto fin = ind_0.end(); - if (pos != fin) {fin = pos; ++fin;} - return make_range(pos, fin); -} -if (cmp > 0) { - return make_range(ind_0.end(), ind_0.end()); -} -return make_range(ind_0.lower_bound(lower, h.hints_0_lower), ind_0.upper_bound(upper, h.hints_0_upper)); -} -range lowerUpperRange_1(const t_tuple& lower, const t_tuple& upper) const { -context h; -return lowerUpperRange_1(lower,upper,h); -} -bool empty() const { -return ind_0.empty(); -} -std::vector> partition() const { -return ind_0.getChunks(400); -} -void purge() { -ind_0.clear(); -} -iterator begin() const { -return ind_0.begin(); -} -iterator end() const { -return ind_0.end(); -} -void printStatistics(std::ostream& o) const { -o << " arity 1 direct b-tree index 0 lex-order [0]\n"; -ind_0.printStats(o); -} -}; -struct t_btree_ii__0_1__11__10 { -static constexpr Relation::arity_type Arity = 2; -using t_tuple = Tuple; -struct t_comparator_0{ - int operator()(const t_tuple& a, const t_tuple& b) const { - return (ramBitCast(a[0]) < ramBitCast(b[0])) ? -1 : (ramBitCast(a[0]) > ramBitCast(b[0])) ? 1 :((ramBitCast(a[1]) < ramBitCast(b[1])) ? -1 : (ramBitCast(a[1]) > ramBitCast(b[1])) ? 1 :(0)); - } -bool less(const t_tuple& a, const t_tuple& b) const { - return (ramBitCast(a[0]) < ramBitCast(b[0]))|| ((ramBitCast(a[0]) == ramBitCast(b[0])) && ((ramBitCast(a[1]) < ramBitCast(b[1])))); - } -bool equal(const t_tuple& a, const t_tuple& b) const { -return (ramBitCast(a[0]) == ramBitCast(b[0]))&&(ramBitCast(a[1]) == ramBitCast(b[1])); - } -}; -using t_ind_0 = btree_set; -t_ind_0 ind_0; -using iterator = t_ind_0::iterator; -struct context { -t_ind_0::operation_hints hints_0_lower; -t_ind_0::operation_hints hints_0_upper; -}; -context createContext() { return context(); } -bool insert(const t_tuple& t) { -context h; -return insert(t, h); -} -bool insert(const t_tuple& t, context& h) { -if (ind_0.insert(t, h.hints_0_lower)) { -return true; -} else return false; -} -bool insert(const RamDomain* ramDomain) { -RamDomain data[2]; -std::copy(ramDomain, ramDomain + 2, data); -const t_tuple& tuple = reinterpret_cast(data); -context h; -return insert(tuple, h); -} -bool insert(RamDomain a0,RamDomain a1) { -RamDomain data[2] = {a0,a1}; -return insert(data); -} -bool contains(const t_tuple& t, context& h) const { -return ind_0.contains(t, h.hints_0_lower); -} -bool contains(const t_tuple& t) const { -context h; -return contains(t, h); -} -std::size_t size() const { -return ind_0.size(); -} -iterator find(const t_tuple& t, context& h) const { -return ind_0.find(t, h.hints_0_lower); -} -iterator find(const t_tuple& t) const { -context h; -return find(t, h); -} -range lowerUpperRange_00(const t_tuple& /* lower */, const t_tuple& /* upper */, context& /* h */) const { -return range(ind_0.begin(),ind_0.end()); -} -range lowerUpperRange_00(const t_tuple& /* lower */, const t_tuple& /* upper */) const { -return range(ind_0.begin(),ind_0.end()); -} -range lowerUpperRange_11(const t_tuple& lower, const t_tuple& upper, context& h) const { -t_comparator_0 comparator; -int cmp = comparator(lower, upper); -if (cmp == 0) { - auto pos = ind_0.find(lower, h.hints_0_lower); - auto fin = ind_0.end(); - if (pos != fin) {fin = pos; ++fin;} - return make_range(pos, fin); -} -if (cmp > 0) { - return make_range(ind_0.end(), ind_0.end()); -} -return make_range(ind_0.lower_bound(lower, h.hints_0_lower), ind_0.upper_bound(upper, h.hints_0_upper)); -} -range lowerUpperRange_11(const t_tuple& lower, const t_tuple& upper) const { -context h; -return lowerUpperRange_11(lower,upper,h); -} -range lowerUpperRange_10(const t_tuple& lower, const t_tuple& upper, context& h) const { -t_comparator_0 comparator; -int cmp = comparator(lower, upper); -if (cmp > 0) { - return make_range(ind_0.end(), ind_0.end()); -} -return make_range(ind_0.lower_bound(lower, h.hints_0_lower), ind_0.upper_bound(upper, h.hints_0_upper)); -} -range lowerUpperRange_10(const t_tuple& lower, const t_tuple& upper) const { -context h; -return lowerUpperRange_10(lower,upper,h); -} -bool empty() const { -return ind_0.empty(); -} -std::vector> partition() const { -return ind_0.getChunks(400); -} -void purge() { -ind_0.clear(); -} -iterator begin() const { -return ind_0.begin(); -} -iterator end() const { -return ind_0.end(); -} -void printStatistics(std::ostream& o) const { -o << " arity 2 direct b-tree index 0 lex-order [0,1]\n"; -ind_0.printStats(o); -} -}; - -class Sf_ext_stg_gc : public SouffleProgram { -private: -static inline std::string substr_wrapper(const std::string& str, std::size_t idx, std::size_t len) { - std::string result; - try { result = str.substr(idx,len); } catch(...) { - std::cerr << "warning: wrong index position provided by substr(\""; - std::cerr << str << "\"," << (int32_t)idx << "," << (int32_t)len << ") functor.\n"; - } return result; -} -public: -// -- initialize symbol table -- -SymbolTableImpl symTable;// -- initialize record table -- -SpecializedRecordTable<0> recordTable{}; -// -- Table: GCRoot -Own rel_1_GCRoot = mk(); -souffle::RelationWrapper wrapper_rel_1_GCRoot; -// -- Table: Reference -Own rel_2_Reference = mk(); -souffle::RelationWrapper wrapper_rel_2_Reference; -// -- Table: LiveStep0 -Own rel_3_LiveStep0 = mk(); -souffle::RelationWrapper wrapper_rel_3_LiveStep0; -// -- Table: @delta_LiveStep0 -Own rel_4_delta_LiveStep0 = mk(); -// -- Table: @new_LiveStep0 -Own rel_5_new_LiveStep0 = mk(); -// -- Table: MaybeDeadlockingThread -Own rel_6_MaybeDeadlockingThread = mk(); -souffle::RelationWrapper wrapper_rel_6_MaybeDeadlockingThread; -// -- Table: DeadlockingThread -Own rel_7_DeadlockingThread = mk(); -souffle::RelationWrapper wrapper_rel_7_DeadlockingThread; -// -- Table: Live -Own rel_8_Live = mk(); -souffle::RelationWrapper wrapper_rel_8_Live; -// -- Table: @delta_Live -Own rel_9_delta_Live = mk(); -// -- Table: @new_Live -Own rel_10_new_Live = mk(); -public: -Sf_ext_stg_gc() -: wrapper_rel_1_GCRoot(0, *rel_1_GCRoot, *this, "GCRoot", std::array{{"s:symbol"}}, std::array{{"val"}}, 0) -, wrapper_rel_2_Reference(1, *rel_2_Reference, *this, "Reference", std::array{{"s:symbol","s:symbol"}}, std::array{{"from","to"}}, 0) -, wrapper_rel_3_LiveStep0(2, *rel_3_LiveStep0, *this, "LiveStep0", std::array{{"s:symbol"}}, std::array{{"val"}}, 0) -, wrapper_rel_6_MaybeDeadlockingThread(3, *rel_6_MaybeDeadlockingThread, *this, "MaybeDeadlockingThread", std::array{{"s:symbol"}}, std::array{{"threadId"}}, 0) -, wrapper_rel_7_DeadlockingThread(4, *rel_7_DeadlockingThread, *this, "DeadlockingThread", std::array{{"s:symbol"}}, std::array{{"threadId"}}, 0) -, wrapper_rel_8_Live(5, *rel_8_Live, *this, "Live", std::array{{"s:symbol"}}, std::array{{"val"}}, 0) +#include "souffle/SignalHandler.h" +#include "souffle/SouffleInterface.h" +#include "souffle/datastructure/BTree.h" +#include "souffle/io/IOSystem.h" +#include "souffle/utility/MiscUtil.h" +#include +namespace functors { -addRelation("GCRoot", wrapper_rel_1_GCRoot, true, false); -addRelation("Reference", wrapper_rel_2_Reference, true, false); -addRelation("LiveStep0", wrapper_rel_3_LiveStep0, false, false); -addRelation("MaybeDeadlockingThread", wrapper_rel_6_MaybeDeadlockingThread, true, false); -addRelation("DeadlockingThread", wrapper_rel_7_DeadlockingThread, false, true); -addRelation("Live", wrapper_rel_8_Live, false, true); -} -~Sf_ext_stg_gc() { -} - -private: -std::string inputDirectory; -std::string outputDirectory; -SignalHandler* signalHandler {SignalHandler::instance()}; -std::atomic ctr {}; -std::atomic iter {}; - -void runFunction(std::string inputDirectoryArg, - std::string outputDirectoryArg, - bool performIOArg, - bool pruneImdtRelsArg) { - this->inputDirectory = std::move(inputDirectoryArg); - this->outputDirectory = std::move(outputDirectoryArg); - this->performIO = performIOArg; - this->pruneImdtRels = pruneImdtRelsArg; - - // set default threads (in embedded mode) - // if this is not set, and omp is used, the default omp setting of number of cores is used. -#if defined(_OPENMP) - if (0 < getNumThreads()) { omp_set_num_threads(static_cast(getNumThreads())); } -#endif - - signalHandler->set(); -// -- query evaluation -- + extern "C" + { + } +} // namespace functors +namespace souffle::t_btree_000_i__0__1 { - std::vector args, ret; -subroutine_0(args, ret); -} + using namespace souffle; + struct Type + { + static constexpr Relation::arity_type Arity = 1; + using t_tuple = Tuple; + struct t_comparator_0 + { + int operator()(const t_tuple &a, const t_tuple &b) const + { + return (ramBitCast(a[0]) < ramBitCast(b[0])) ? -1 : (ramBitCast(a[0]) > ramBitCast(b[0])) ? 1 + : (0); + } + bool less(const t_tuple &a, const t_tuple &b) const + { + return (ramBitCast(a[0]) < ramBitCast(b[0])); + } + bool equal(const t_tuple &a, const t_tuple &b) const + { + return (ramBitCast(a[0]) == ramBitCast(b[0])); + } + }; + using t_ind_0 = btree_set; + t_ind_0 ind_0; + using iterator = t_ind_0::iterator; + struct context + { + t_ind_0::operation_hints hints_0_lower; + t_ind_0::operation_hints hints_0_upper; + }; + context createContext() { return context(); } + bool insert(const t_tuple &t); + bool insert(const t_tuple &t, context &h); + bool insert(const RamDomain *ramDomain); + bool insert(RamDomain a0); + bool contains(const t_tuple &t, context &h) const; + bool contains(const t_tuple &t) const; + std::size_t size() const; + iterator find(const t_tuple &t, context &h) const; + iterator find(const t_tuple &t) const; + range lowerUpperRange_0(const t_tuple & /* lower */, const t_tuple & /* upper */, context & /* h */) const; + range lowerUpperRange_0(const t_tuple & /* lower */, const t_tuple & /* upper */) const; + range lowerUpperRange_1(const t_tuple &lower, const t_tuple &upper, context &h) const; + range lowerUpperRange_1(const t_tuple &lower, const t_tuple &upper) const; + bool empty() const; + std::vector> partition() const; + void purge(); + iterator begin() const; + iterator end() const; + void printStatistics(std::ostream &o) const; + }; +} // namespace souffle::t_btree_000_i__0__1 +namespace souffle::t_btree_000_i__0__1 { - std::vector args, ret; -subroutine_1(args, ret); -} + using namespace souffle; + using t_ind_0 = Type::t_ind_0; + using iterator = Type::iterator; + using context = Type::context; + bool Type::insert(const t_tuple &t) + { + context h; + return insert(t, h); + } + bool Type::insert(const t_tuple &t, context &h) + { + if (ind_0.insert(t, h.hints_0_lower)) + { + return true; + } + else + return false; + } + bool Type::insert(const RamDomain *ramDomain) + { + RamDomain data[1]; + std::copy(ramDomain, ramDomain + 1, data); + const t_tuple &tuple = reinterpret_cast(data); + context h; + return insert(tuple, h); + } + bool Type::insert(RamDomain a0) + { + RamDomain data[1] = {a0}; + return insert(data); + } + bool Type::contains(const t_tuple &t, context &h) const + { + return ind_0.contains(t, h.hints_0_lower); + } + bool Type::contains(const t_tuple &t) const + { + context h; + return contains(t, h); + } + std::size_t Type::size() const + { + return ind_0.size(); + } + iterator Type::find(const t_tuple &t, context &h) const + { + return ind_0.find(t, h.hints_0_lower); + } + iterator Type::find(const t_tuple &t) const + { + context h; + return find(t, h); + } + range Type::lowerUpperRange_0(const t_tuple & /* lower */, const t_tuple & /* upper */, context & /* h */) const + { + return range(ind_0.begin(), ind_0.end()); + } + range Type::lowerUpperRange_0(const t_tuple & /* lower */, const t_tuple & /* upper */) const + { + return range(ind_0.begin(), ind_0.end()); + } + range Type::lowerUpperRange_1(const t_tuple &lower, const t_tuple &upper, context &h) const + { + t_comparator_0 comparator; + int cmp = comparator(lower, upper); + if (cmp == 0) + { + auto pos = ind_0.find(lower, h.hints_0_lower); + auto fin = ind_0.end(); + if (pos != fin) + { + fin = pos; + ++fin; + } + return make_range(pos, fin); + } + if (cmp > 0) + { + return make_range(ind_0.end(), ind_0.end()); + } + return make_range(ind_0.lower_bound(lower, h.hints_0_lower), ind_0.upper_bound(upper, h.hints_0_upper)); + } + range Type::lowerUpperRange_1(const t_tuple &lower, const t_tuple &upper) const + { + context h; + return lowerUpperRange_1(lower, upper, h); + } + bool Type::empty() const + { + return ind_0.empty(); + } + std::vector> Type::partition() const + { + return ind_0.getChunks(400); + } + void Type::purge() + { + ind_0.clear(); + } + iterator Type::begin() const + { + return ind_0.begin(); + } + iterator Type::end() const + { + return ind_0.end(); + } + void Type::printStatistics(std::ostream &o) const + { + o << " arity 1 direct b-tree index 0 lex-order [0]\n"; + ind_0.printStats(o); + } +} // namespace souffle::t_btree_000_i__0__1 +namespace souffle::t_btree_000_ii__0_1__11__10 { - std::vector args, ret; -subroutine_2(args, ret); -} + using namespace souffle; + struct Type + { + static constexpr Relation::arity_type Arity = 2; + using t_tuple = Tuple; + struct t_comparator_0 + { + int operator()(const t_tuple &a, const t_tuple &b) const + { + return (ramBitCast(a[0]) < ramBitCast(b[0])) ? -1 : (ramBitCast(a[0]) > ramBitCast(b[0])) ? 1 + : ((ramBitCast(a[1]) < ramBitCast(b[1])) ? -1 : (ramBitCast(a[1]) > ramBitCast(b[1])) ? 1 + : (0)); + } + bool less(const t_tuple &a, const t_tuple &b) const + { + return (ramBitCast(a[0]) < ramBitCast(b[0])) || ((ramBitCast(a[0]) == ramBitCast(b[0])) && ((ramBitCast(a[1]) < ramBitCast(b[1])))); + } + bool equal(const t_tuple &a, const t_tuple &b) const + { + return (ramBitCast(a[0]) == ramBitCast(b[0])) && (ramBitCast(a[1]) == ramBitCast(b[1])); + } + }; + using t_ind_0 = btree_set; + t_ind_0 ind_0; + using iterator = t_ind_0::iterator; + struct context + { + t_ind_0::operation_hints hints_0_lower; + t_ind_0::operation_hints hints_0_upper; + }; + context createContext() { return context(); } + bool insert(const t_tuple &t); + bool insert(const t_tuple &t, context &h); + bool insert(const RamDomain *ramDomain); + bool insert(RamDomain a0, RamDomain a1); + bool contains(const t_tuple &t, context &h) const; + bool contains(const t_tuple &t) const; + std::size_t size() const; + iterator find(const t_tuple &t, context &h) const; + iterator find(const t_tuple &t) const; + range lowerUpperRange_00(const t_tuple & /* lower */, const t_tuple & /* upper */, context & /* h */) const; + range lowerUpperRange_00(const t_tuple & /* lower */, const t_tuple & /* upper */) const; + range lowerUpperRange_11(const t_tuple &lower, const t_tuple &upper, context &h) const; + range lowerUpperRange_11(const t_tuple &lower, const t_tuple &upper) const; + range lowerUpperRange_10(const t_tuple &lower, const t_tuple &upper, context &h) const; + range lowerUpperRange_10(const t_tuple &lower, const t_tuple &upper) const; + bool empty() const; + std::vector> partition() const; + void purge(); + iterator begin() const; + iterator end() const; + void printStatistics(std::ostream &o) const; + }; +} // namespace souffle::t_btree_000_ii__0_1__11__10 +namespace souffle::t_btree_000_ii__0_1__11__10 { - std::vector args, ret; -subroutine_3(args, ret); -} + using namespace souffle; + using t_ind_0 = Type::t_ind_0; + using iterator = Type::iterator; + using context = Type::context; + bool Type::insert(const t_tuple &t) + { + context h; + return insert(t, h); + } + bool Type::insert(const t_tuple &t, context &h) + { + if (ind_0.insert(t, h.hints_0_lower)) + { + return true; + } + else + return false; + } + bool Type::insert(const RamDomain *ramDomain) + { + RamDomain data[2]; + std::copy(ramDomain, ramDomain + 2, data); + const t_tuple &tuple = reinterpret_cast(data); + context h; + return insert(tuple, h); + } + bool Type::insert(RamDomain a0, RamDomain a1) + { + RamDomain data[2] = {a0, a1}; + return insert(data); + } + bool Type::contains(const t_tuple &t, context &h) const + { + return ind_0.contains(t, h.hints_0_lower); + } + bool Type::contains(const t_tuple &t) const + { + context h; + return contains(t, h); + } + std::size_t Type::size() const + { + return ind_0.size(); + } + iterator Type::find(const t_tuple &t, context &h) const + { + return ind_0.find(t, h.hints_0_lower); + } + iterator Type::find(const t_tuple &t) const + { + context h; + return find(t, h); + } + range Type::lowerUpperRange_00(const t_tuple & /* lower */, const t_tuple & /* upper */, context & /* h */) const + { + return range(ind_0.begin(), ind_0.end()); + } + range Type::lowerUpperRange_00(const t_tuple & /* lower */, const t_tuple & /* upper */) const + { + return range(ind_0.begin(), ind_0.end()); + } + range Type::lowerUpperRange_11(const t_tuple &lower, const t_tuple &upper, context &h) const + { + t_comparator_0 comparator; + int cmp = comparator(lower, upper); + if (cmp == 0) + { + auto pos = ind_0.find(lower, h.hints_0_lower); + auto fin = ind_0.end(); + if (pos != fin) + { + fin = pos; + ++fin; + } + return make_range(pos, fin); + } + if (cmp > 0) + { + return make_range(ind_0.end(), ind_0.end()); + } + return make_range(ind_0.lower_bound(lower, h.hints_0_lower), ind_0.upper_bound(upper, h.hints_0_upper)); + } + range Type::lowerUpperRange_11(const t_tuple &lower, const t_tuple &upper) const + { + context h; + return lowerUpperRange_11(lower, upper, h); + } + range Type::lowerUpperRange_10(const t_tuple &lower, const t_tuple &upper, context &h) const + { + t_comparator_0 comparator; + int cmp = comparator(lower, upper); + if (cmp > 0) + { + return make_range(ind_0.end(), ind_0.end()); + } + return make_range(ind_0.lower_bound(lower, h.hints_0_lower), ind_0.upper_bound(upper, h.hints_0_upper)); + } + range Type::lowerUpperRange_10(const t_tuple &lower, const t_tuple &upper) const + { + context h; + return lowerUpperRange_10(lower, upper, h); + } + bool Type::empty() const + { + return ind_0.empty(); + } + std::vector> Type::partition() const + { + return ind_0.getChunks(400); + } + void Type::purge() + { + ind_0.clear(); + } + iterator Type::begin() const + { + return ind_0.begin(); + } + iterator Type::end() const + { + return ind_0.end(); + } + void Type::printStatistics(std::ostream &o) const + { + o << " arity 2 direct b-tree index 0 lex-order [0,1]\n"; + ind_0.printStats(o); + } +} // namespace souffle::t_btree_000_ii__0_1__11__10 +namespace souffle { - std::vector args, ret; -subroutine_4(args, ret); -} + using namespace souffle; + class Stratum_DeadlockingThread_69894afebfc94aee + { + public: + Stratum_DeadlockingThread_69894afebfc94aee(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_DeadlockingThread_8fa18e0d3ee84b8b, t_btree_000_i__0__1::Type &rel_LiveStep0_d54eeb7faabc4a13, t_btree_000_i__0__1::Type &rel_MaybeDeadlockingThread_bdb2bd10c95b5982); + void run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret); + + private: + SymbolTable &symTable; + RecordTable &recordTable; + ConcurrentCache ®exCache; + bool &pruneImdtRels; + bool &performIO; + SignalHandler *&signalHandler; + std::atomic &iter; + std::atomic &ctr; + std::string &inputDirectory; + std::string &outputDirectory; + t_btree_000_i__0__1::Type *rel_DeadlockingThread_8fa18e0d3ee84b8b; + t_btree_000_i__0__1::Type *rel_LiveStep0_d54eeb7faabc4a13; + t_btree_000_i__0__1::Type *rel_MaybeDeadlockingThread_bdb2bd10c95b5982; + }; +} // namespace souffle +namespace souffle { - std::vector args, ret; -subroutine_5(args, ret); -} + using namespace souffle; + Stratum_DeadlockingThread_69894afebfc94aee::Stratum_DeadlockingThread_69894afebfc94aee(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_DeadlockingThread_8fa18e0d3ee84b8b, t_btree_000_i__0__1::Type &rel_LiveStep0_d54eeb7faabc4a13, t_btree_000_i__0__1::Type &rel_MaybeDeadlockingThread_bdb2bd10c95b5982) : symTable(symTable), + recordTable(recordTable), + regexCache(regexCache), + pruneImdtRels(pruneImdtRels), + performIO(performIO), + signalHandler(signalHandler), + iter(iter), + ctr(ctr), + inputDirectory(inputDirectory), + outputDirectory(outputDirectory), + rel_DeadlockingThread_8fa18e0d3ee84b8b(&rel_DeadlockingThread_8fa18e0d3ee84b8b), + rel_LiveStep0_d54eeb7faabc4a13(&rel_LiveStep0_d54eeb7faabc4a13), + rel_MaybeDeadlockingThread_bdb2bd10c95b5982(&rel_MaybeDeadlockingThread_bdb2bd10c95b5982) + { + } -// -- relation hint statistics -- -signalHandler->reset(); -} -public: -void run() override { runFunction("", "", false, false); } -public: -void runAll(std::string inputDirectoryArg = "", std::string outputDirectoryArg = "", bool performIOArg=true, bool pruneImdtRelsArg=true) override { runFunction(inputDirectoryArg, outputDirectoryArg, performIOArg, pruneImdtRelsArg); -} -public: -void printAll(std::string outputDirectoryArg = "") override { -try {std::map directiveMap({{"IO","file"},{"attributeNames","threadId"},{"auxArity","0"},{"name","DeadlockingThread"},{"operation","output"},{"output-dir","."},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"threadId\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!outputDirectoryArg.empty()) {directiveMap["output-dir"] = outputDirectoryArg;} -IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_7_DeadlockingThread); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -try {std::map directiveMap({{"IO","file"},{"attributeNames","val"},{"auxArity","0"},{"name","Live"},{"operation","output"},{"output-dir","."},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"val\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!outputDirectoryArg.empty()) {directiveMap["output-dir"] = outputDirectoryArg;} -IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_8_Live); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -} -public: -void loadAll(std::string inputDirectoryArg = "") override { -try {std::map directiveMap({{"IO","file"},{"attributeNames","val"},{"auxArity","0"},{"fact-dir","."},{"name","GCRoot"},{"operation","input"},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"val\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!inputDirectoryArg.empty()) {directiveMap["fact-dir"] = inputDirectoryArg;} -IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_1_GCRoot); -} catch (std::exception& e) {std::cerr << "Error loading GCRoot data: " << e.what() << '\n';} -try {std::map directiveMap({{"IO","file"},{"attributeNames","threadId"},{"auxArity","0"},{"fact-dir","."},{"name","MaybeDeadlockingThread"},{"operation","input"},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"threadId\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!inputDirectoryArg.empty()) {directiveMap["fact-dir"] = inputDirectoryArg;} -IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_6_MaybeDeadlockingThread); -} catch (std::exception& e) {std::cerr << "Error loading MaybeDeadlockingThread data: " << e.what() << '\n';} -try {std::map directiveMap({{"IO","file"},{"attributeNames","from\tto"},{"auxArity","0"},{"fact-dir","."},{"name","Reference"},{"operation","input"},{"params","{\"records\": {}, \"relation\": {\"arity\": 2, \"params\": [\"from\", \"to\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 2, \"types\": [\"s:symbol\", \"s:symbol\"]}}"}}); -if (!inputDirectoryArg.empty()) {directiveMap["fact-dir"] = inputDirectoryArg;} -IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_2_Reference); -} catch (std::exception& e) {std::cerr << "Error loading Reference data: " << e.what() << '\n';} -} -public: -void dumpInputs() override { -try {std::map rwOperation; -rwOperation["IO"] = "stdout"; -rwOperation["name"] = "GCRoot"; -rwOperation["types"] = "{\"relation\": {\"arity\": 1, \"auxArity\": 0, \"types\": [\"s:symbol\"]}}"; -IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_1_GCRoot); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -try {std::map rwOperation; -rwOperation["IO"] = "stdout"; -rwOperation["name"] = "MaybeDeadlockingThread"; -rwOperation["types"] = "{\"relation\": {\"arity\": 1, \"auxArity\": 0, \"types\": [\"s:symbol\"]}}"; -IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_6_MaybeDeadlockingThread); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -try {std::map rwOperation; -rwOperation["IO"] = "stdout"; -rwOperation["name"] = "Reference"; -rwOperation["types"] = "{\"relation\": {\"arity\": 2, \"auxArity\": 0, \"types\": [\"s:symbol\", \"s:symbol\"]}}"; -IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_2_Reference); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -} -public: -void dumpOutputs() override { -try {std::map rwOperation; -rwOperation["IO"] = "stdout"; -rwOperation["name"] = "DeadlockingThread"; -rwOperation["types"] = "{\"relation\": {\"arity\": 1, \"auxArity\": 0, \"types\": [\"s:symbol\"]}}"; -IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_7_DeadlockingThread); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -try {std::map rwOperation; -rwOperation["IO"] = "stdout"; -rwOperation["name"] = "Live"; -rwOperation["types"] = "{\"relation\": {\"arity\": 1, \"auxArity\": 0, \"types\": [\"s:symbol\"]}}"; -IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_8_Live); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -} -public: -SymbolTable& getSymbolTable() override { -return symTable; -} -RecordTable& getRecordTable() override { -return recordTable; -} -void setNumThreads(std::size_t numThreadsValue) override { -SouffleProgram::setNumThreads(numThreadsValue); -symTable.setNumLanes(getNumThreads()); -recordTable.setNumLanes(getNumThreads()); -} -void executeSubroutine(std::string name, const std::vector& args, std::vector& ret) override { -if (name == "stratum_0") { -subroutine_0(args, ret); -return;} -if (name == "stratum_1") { -subroutine_1(args, ret); -return;} -if (name == "stratum_2") { -subroutine_2(args, ret); -return;} -if (name == "stratum_3") { -subroutine_3(args, ret); -return;} -if (name == "stratum_4") { -subroutine_4(args, ret); -return;} -if (name == "stratum_5") { -subroutine_5(args, ret); -return;} -fatal("unknown subroutine"); -} -#ifdef _MSC_VER -#pragma warning(disable: 4100) -#endif // _MSC_VER -void subroutine_0(const std::vector& args, std::vector& ret) { -if (performIO) { -try {std::map directiveMap({{"IO","file"},{"attributeNames","val"},{"auxArity","0"},{"fact-dir","."},{"name","GCRoot"},{"operation","input"},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"val\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!inputDirectory.empty()) {directiveMap["fact-dir"] = inputDirectory;} -IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_1_GCRoot); -} catch (std::exception& e) {std::cerr << "Error loading GCRoot data: " << e.what() << '\n';} -} -} -#ifdef _MSC_VER -#pragma warning(default: 4100) -#endif // _MSC_VER -#ifdef _MSC_VER -#pragma warning(disable: 4100) -#endif // _MSC_VER -void subroutine_1(const std::vector& args, std::vector& ret) { -if (performIO) { -try {std::map directiveMap({{"IO","file"},{"attributeNames","from\tto"},{"auxArity","0"},{"fact-dir","."},{"name","Reference"},{"operation","input"},{"params","{\"records\": {}, \"relation\": {\"arity\": 2, \"params\": [\"from\", \"to\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 2, \"types\": [\"s:symbol\", \"s:symbol\"]}}"}}); -if (!inputDirectory.empty()) {directiveMap["fact-dir"] = inputDirectory;} -IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_2_Reference); -} catch (std::exception& e) {std::cerr << "Error loading Reference data: " << e.what() << '\n';} -} -} -#ifdef _MSC_VER -#pragma warning(default: 4100) -#endif // _MSC_VER -#ifdef _MSC_VER -#pragma warning(disable: 4100) -#endif // _MSC_VER -void subroutine_2(const std::vector& args, std::vector& ret) { -signalHandler->setMsg(R"_(LiveStep0(ref) :- - GCRoot(ref). -in file ext-stg-gc.dl [26:1-26:31])_"); -if(!(rel_1_GCRoot->empty())) { -[&](){ -CREATE_OP_CONTEXT(rel_3_LiveStep0_op_ctxt,rel_3_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_1_GCRoot_op_ctxt,rel_1_GCRoot->createContext()); -for(const auto& env0 : *rel_1_GCRoot) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_3_LiveStep0->insert(tuple,READ_OP_CONTEXT(rel_3_LiveStep0_op_ctxt)); -} -} -();} -[&](){ -CREATE_OP_CONTEXT(rel_3_LiveStep0_op_ctxt,rel_3_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_4_delta_LiveStep0_op_ctxt,rel_4_delta_LiveStep0->createContext()); -for(const auto& env0 : *rel_3_LiveStep0) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_4_delta_LiveStep0->insert(tuple,READ_OP_CONTEXT(rel_4_delta_LiveStep0_op_ctxt)); -} -} -();iter = 0; -for(;;) { -signalHandler->setMsg(R"_(LiveStep0(to) :- - LiveStep0(from), - Reference(from,to). -in file ext-stg-gc.dl [28:1-30:23])_"); -if(!(rel_4_delta_LiveStep0->empty()) && !(rel_2_Reference->empty())) { -[&](){ -auto part = rel_4_delta_LiveStep0->partition(); -PARALLEL_START -CREATE_OP_CONTEXT(rel_3_LiveStep0_op_ctxt,rel_3_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_4_delta_LiveStep0_op_ctxt,rel_4_delta_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_5_new_LiveStep0_op_ctxt,rel_5_new_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_2_Reference_op_ctxt,rel_2_Reference->createContext()); - - #if defined _OPENMP && _OPENMP < 200805 - auto count = std::distance(part.begin(), part.end()); - auto base = part.begin(); - pfor(int index = 0; index < count; index++) { - auto it = base + index; - #else - pfor(auto it = part.begin(); it < part.end(); it++) { - #endif - try{ -for(const auto& env0 : *it) { -auto range = rel_2_Reference->lowerUpperRange_10(Tuple{{ramBitCast(env0[0]), ramBitCast(MIN_RAM_SIGNED)}},Tuple{{ramBitCast(env0[0]), ramBitCast(MAX_RAM_SIGNED)}},READ_OP_CONTEXT(rel_2_Reference_op_ctxt)); -for(const auto& env1 : range) { -if( !(rel_3_LiveStep0->contains(Tuple{{ramBitCast(env1[1])}},READ_OP_CONTEXT(rel_3_LiveStep0_op_ctxt)))) { -Tuple tuple{{ramBitCast(env1[1])}}; -rel_5_new_LiveStep0->insert(tuple,READ_OP_CONTEXT(rel_5_new_LiveStep0_op_ctxt)); -} -} -} -} catch(std::exception &e) { signalHandler->error(e.what());} -} -PARALLEL_END -} -();} -if(rel_5_new_LiveStep0->empty()) break; -[&](){ -CREATE_OP_CONTEXT(rel_3_LiveStep0_op_ctxt,rel_3_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_5_new_LiveStep0_op_ctxt,rel_5_new_LiveStep0->createContext()); -for(const auto& env0 : *rel_5_new_LiveStep0) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_3_LiveStep0->insert(tuple,READ_OP_CONTEXT(rel_3_LiveStep0_op_ctxt)); -} -} -();std::swap(rel_4_delta_LiveStep0, rel_5_new_LiveStep0); -rel_5_new_LiveStep0->purge(); -iter++; -} -iter = 0; -rel_4_delta_LiveStep0->purge(); -rel_5_new_LiveStep0->purge(); -if (pruneImdtRels) rel_1_GCRoot->purge(); -} -#ifdef _MSC_VER -#pragma warning(default: 4100) -#endif // _MSC_VER -#ifdef _MSC_VER -#pragma warning(disable: 4100) -#endif // _MSC_VER -void subroutine_3(const std::vector& args, std::vector& ret) { -if (performIO) { -try {std::map directiveMap({{"IO","file"},{"attributeNames","threadId"},{"auxArity","0"},{"fact-dir","."},{"name","MaybeDeadlockingThread"},{"operation","input"},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"threadId\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!inputDirectory.empty()) {directiveMap["fact-dir"] = inputDirectory;} -IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_6_MaybeDeadlockingThread); -} catch (std::exception& e) {std::cerr << "Error loading MaybeDeadlockingThread data: " << e.what() << '\n';} -} -} -#ifdef _MSC_VER -#pragma warning(default: 4100) -#endif // _MSC_VER -#ifdef _MSC_VER -#pragma warning(disable: 4100) -#endif // _MSC_VER -void subroutine_4(const std::vector& args, std::vector& ret) { -signalHandler->setMsg(R"_(DeadlockingThread(tid) :- + void Stratum_DeadlockingThread_69894afebfc94aee::run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret) + { + signalHandler->setMsg(R"_(DeadlockingThread(tid) :- MaybeDeadlockingThread(tid), !LiveStep0(tid). -in file ext-stg-gc.dl [41:1-43:19])_"); -if(!(rel_6_MaybeDeadlockingThread->empty())) { -[&](){ -auto part = rel_6_MaybeDeadlockingThread->partition(); -PARALLEL_START -CREATE_OP_CONTEXT(rel_3_LiveStep0_op_ctxt,rel_3_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_6_MaybeDeadlockingThread_op_ctxt,rel_6_MaybeDeadlockingThread->createContext()); -CREATE_OP_CONTEXT(rel_7_DeadlockingThread_op_ctxt,rel_7_DeadlockingThread->createContext()); - - #if defined _OPENMP && _OPENMP < 200805 - auto count = std::distance(part.begin(), part.end()); - auto base = part.begin(); - pfor(int index = 0; index < count; index++) { - auto it = base + index; - #else - pfor(auto it = part.begin(); it < part.end(); it++) { - #endif - try{ -for(const auto& env0 : *it) { -if( !(rel_3_LiveStep0->contains(Tuple{{ramBitCast(env0[0])}},READ_OP_CONTEXT(rel_3_LiveStep0_op_ctxt)))) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_7_DeadlockingThread->insert(tuple,READ_OP_CONTEXT(rel_7_DeadlockingThread_op_ctxt)); -} -} -} catch(std::exception &e) { signalHandler->error(e.what());} -} -PARALLEL_END -} -();} -if (performIO) { -try {std::map directiveMap({{"IO","file"},{"attributeNames","threadId"},{"auxArity","0"},{"name","DeadlockingThread"},{"operation","output"},{"output-dir","."},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"threadId\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!outputDirectory.empty()) {directiveMap["output-dir"] = outputDirectory;} -IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_7_DeadlockingThread); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -} -if (pruneImdtRels) rel_6_MaybeDeadlockingThread->purge(); -} -#ifdef _MSC_VER -#pragma warning(default: 4100) -#endif // _MSC_VER -#ifdef _MSC_VER -#pragma warning(disable: 4100) -#endif // _MSC_VER -void subroutine_5(const std::vector& args, std::vector& ret) { -signalHandler->setMsg(R"_(Live(tid) :- +in file ext-stg-gc.dl [32:1-34:19])_"); + if (!(rel_MaybeDeadlockingThread_bdb2bd10c95b5982->empty())) + { + [&]() + { + CREATE_OP_CONTEXT(rel_DeadlockingThread_8fa18e0d3ee84b8b_op_ctxt, rel_DeadlockingThread_8fa18e0d3ee84b8b->createContext()); + CREATE_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt, rel_LiveStep0_d54eeb7faabc4a13->createContext()); + CREATE_OP_CONTEXT(rel_MaybeDeadlockingThread_bdb2bd10c95b5982_op_ctxt, rel_MaybeDeadlockingThread_bdb2bd10c95b5982->createContext()); + for (const auto &env0 : *rel_MaybeDeadlockingThread_bdb2bd10c95b5982) + { + if (!(rel_LiveStep0_d54eeb7faabc4a13->contains(Tuple{{ramBitCast(env0[0])}}, READ_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt)))) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_DeadlockingThread_8fa18e0d3ee84b8b->insert(tuple, READ_OP_CONTEXT(rel_DeadlockingThread_8fa18e0d3ee84b8b_op_ctxt)); + } + } + }(); + } + if (performIO) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(threadId)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(name)_", R"_(DeadlockingThread)_"}, {R"_(operation)_", R"_(output)_"}, {R"_(output-dir)_", R"_(.)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["threadId"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (outputDirectory == "-") + { + directiveMap["IO"] = "stdout"; + directiveMap["headers"] = "true"; + } + else if (!outputDirectory.empty()) + { + directiveMap["output-dir"] = outputDirectory; + } + IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_DeadlockingThread_8fa18e0d3ee84b8b); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + } + if (pruneImdtRels) + rel_MaybeDeadlockingThread_bdb2bd10c95b5982->purge(); + } + +} // namespace souffle + +namespace souffle +{ + using namespace souffle; + class Stratum_GCRoot_b08a674c48c5fe0e + { + public: + Stratum_GCRoot_b08a674c48c5fe0e(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_GCRoot_f9754bdf5b76c5df); + void run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret); + + private: + SymbolTable &symTable; + RecordTable &recordTable; + ConcurrentCache ®exCache; + bool &pruneImdtRels; + bool &performIO; + SignalHandler *&signalHandler; + std::atomic &iter; + std::atomic &ctr; + std::string &inputDirectory; + std::string &outputDirectory; + t_btree_000_i__0__1::Type *rel_GCRoot_f9754bdf5b76c5df; + }; +} // namespace souffle +namespace souffle +{ + using namespace souffle; + Stratum_GCRoot_b08a674c48c5fe0e::Stratum_GCRoot_b08a674c48c5fe0e(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_GCRoot_f9754bdf5b76c5df) : symTable(symTable), + recordTable(recordTable), + regexCache(regexCache), + pruneImdtRels(pruneImdtRels), + performIO(performIO), + signalHandler(signalHandler), + iter(iter), + ctr(ctr), + inputDirectory(inputDirectory), + outputDirectory(outputDirectory), + rel_GCRoot_f9754bdf5b76c5df(&rel_GCRoot_f9754bdf5b76c5df) + { + } + + void Stratum_GCRoot_b08a674c48c5fe0e::run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret) + { + if (performIO) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(val)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(fact-dir)_", R"_(.)_"}, {R"_(name)_", R"_(GCRoot)_"}, {R"_(operation)_", R"_(input)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["val"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (!inputDirectory.empty()) + { + directiveMap["fact-dir"] = inputDirectory; + } + IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_GCRoot_f9754bdf5b76c5df); + } + catch (std::exception &e) + { + std::cerr << "Error loading GCRoot data: " << e.what() << '\n'; + exit(1); + } + } + } + +} // namespace souffle + +namespace souffle +{ + using namespace souffle; + class Stratum_Live_b9069971975f423e + { + public: + Stratum_Live_b9069971975f423e(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_delta_Live_2c57e9662e50a2a0, t_btree_000_i__0__1::Type &rel_new_Live_ca472dbac4201e48, t_btree_000_i__0__1::Type &rel_DeadlockingThread_8fa18e0d3ee84b8b, t_btree_000_i__0__1::Type &rel_Live_2818460375647c67, t_btree_000_i__0__1::Type &rel_LiveStep0_d54eeb7faabc4a13, t_btree_000_ii__0_1__11__10::Type &rel_Reference_c57e388e43703de5); + void run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret); + + private: + SymbolTable &symTable; + RecordTable &recordTable; + ConcurrentCache ®exCache; + bool &pruneImdtRels; + bool &performIO; + SignalHandler *&signalHandler; + std::atomic &iter; + std::atomic &ctr; + std::string &inputDirectory; + std::string &outputDirectory; + t_btree_000_i__0__1::Type *rel_delta_Live_2c57e9662e50a2a0; + t_btree_000_i__0__1::Type *rel_new_Live_ca472dbac4201e48; + t_btree_000_i__0__1::Type *rel_DeadlockingThread_8fa18e0d3ee84b8b; + t_btree_000_i__0__1::Type *rel_Live_2818460375647c67; + t_btree_000_i__0__1::Type *rel_LiveStep0_d54eeb7faabc4a13; + t_btree_000_ii__0_1__11__10::Type *rel_Reference_c57e388e43703de5; + }; +} // namespace souffle +namespace souffle +{ + using namespace souffle; + Stratum_Live_b9069971975f423e::Stratum_Live_b9069971975f423e(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_delta_Live_2c57e9662e50a2a0, t_btree_000_i__0__1::Type &rel_new_Live_ca472dbac4201e48, t_btree_000_i__0__1::Type &rel_DeadlockingThread_8fa18e0d3ee84b8b, t_btree_000_i__0__1::Type &rel_Live_2818460375647c67, t_btree_000_i__0__1::Type &rel_LiveStep0_d54eeb7faabc4a13, t_btree_000_ii__0_1__11__10::Type &rel_Reference_c57e388e43703de5) : symTable(symTable), + recordTable(recordTable), + regexCache(regexCache), + pruneImdtRels(pruneImdtRels), + performIO(performIO), + signalHandler(signalHandler), + iter(iter), + ctr(ctr), + inputDirectory(inputDirectory), + outputDirectory(outputDirectory), + rel_delta_Live_2c57e9662e50a2a0(&rel_delta_Live_2c57e9662e50a2a0), + rel_new_Live_ca472dbac4201e48(&rel_new_Live_ca472dbac4201e48), + rel_DeadlockingThread_8fa18e0d3ee84b8b(&rel_DeadlockingThread_8fa18e0d3ee84b8b), + rel_Live_2818460375647c67(&rel_Live_2818460375647c67), + rel_LiveStep0_d54eeb7faabc4a13(&rel_LiveStep0_d54eeb7faabc4a13), + rel_Reference_c57e388e43703de5(&rel_Reference_c57e388e43703de5) + { + } + + void Stratum_Live_b9069971975f423e::run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret) + { + signalHandler->setMsg(R"_(Live(tid) :- DeadlockingThread(tid). -in file ext-stg-gc.dl [45:1-45:37])_"); -if(!(rel_7_DeadlockingThread->empty())) { -[&](){ -CREATE_OP_CONTEXT(rel_7_DeadlockingThread_op_ctxt,rel_7_DeadlockingThread->createContext()); -CREATE_OP_CONTEXT(rel_8_Live_op_ctxt,rel_8_Live->createContext()); -for(const auto& env0 : *rel_7_DeadlockingThread) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_8_Live->insert(tuple,READ_OP_CONTEXT(rel_8_Live_op_ctxt)); -} -} -();} -signalHandler->setMsg(R"_(Live(ref) :- +in file ext-stg-gc.dl [36:1-36:37])_"); + if (!(rel_DeadlockingThread_8fa18e0d3ee84b8b->empty())) + { + [&]() + { + CREATE_OP_CONTEXT(rel_DeadlockingThread_8fa18e0d3ee84b8b_op_ctxt, rel_DeadlockingThread_8fa18e0d3ee84b8b->createContext()); + CREATE_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt, rel_Live_2818460375647c67->createContext()); + for (const auto &env0 : *rel_DeadlockingThread_8fa18e0d3ee84b8b) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_Live_2818460375647c67->insert(tuple, READ_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt)); + } + }(); + } + signalHandler->setMsg(R"_(Live(ref) :- LiveStep0(ref). -in file ext-stg-gc.dl [46:1-46:29])_"); -if(!(rel_3_LiveStep0->empty())) { -[&](){ -CREATE_OP_CONTEXT(rel_3_LiveStep0_op_ctxt,rel_3_LiveStep0->createContext()); -CREATE_OP_CONTEXT(rel_8_Live_op_ctxt,rel_8_Live->createContext()); -for(const auto& env0 : *rel_3_LiveStep0) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_8_Live->insert(tuple,READ_OP_CONTEXT(rel_8_Live_op_ctxt)); -} -} -();} -[&](){ -CREATE_OP_CONTEXT(rel_8_Live_op_ctxt,rel_8_Live->createContext()); -CREATE_OP_CONTEXT(rel_9_delta_Live_op_ctxt,rel_9_delta_Live->createContext()); -for(const auto& env0 : *rel_8_Live) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_9_delta_Live->insert(tuple,READ_OP_CONTEXT(rel_9_delta_Live_op_ctxt)); -} -} -();iter = 0; -for(;;) { -signalHandler->setMsg(R"_(Live(to) :- +in file ext-stg-gc.dl [37:1-37:29])_"); + if (!(rel_LiveStep0_d54eeb7faabc4a13->empty())) + { + [&]() + { + CREATE_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt, rel_Live_2818460375647c67->createContext()); + CREATE_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt, rel_LiveStep0_d54eeb7faabc4a13->createContext()); + for (const auto &env0 : *rel_LiveStep0_d54eeb7faabc4a13) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_Live_2818460375647c67->insert(tuple, READ_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt)); + } + }(); + } + [&]() + { + CREATE_OP_CONTEXT(rel_delta_Live_2c57e9662e50a2a0_op_ctxt, rel_delta_Live_2c57e9662e50a2a0->createContext()); + CREATE_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt, rel_Live_2818460375647c67->createContext()); + for (const auto &env0 : *rel_Live_2818460375647c67) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_delta_Live_2c57e9662e50a2a0->insert(tuple, READ_OP_CONTEXT(rel_delta_Live_2c57e9662e50a2a0_op_ctxt)); + } + }(); + auto loop_counter = RamUnsigned(1); + iter = 0; + for (;;) + { + signalHandler->setMsg(R"_(Live(to) :- Live(from), Reference(from,to). -in file ext-stg-gc.dl [47:1-49:23])_"); -if(!(rel_9_delta_Live->empty()) && !(rel_2_Reference->empty())) { -[&](){ -auto part = rel_9_delta_Live->partition(); -PARALLEL_START -CREATE_OP_CONTEXT(rel_2_Reference_op_ctxt,rel_2_Reference->createContext()); -CREATE_OP_CONTEXT(rel_8_Live_op_ctxt,rel_8_Live->createContext()); -CREATE_OP_CONTEXT(rel_9_delta_Live_op_ctxt,rel_9_delta_Live->createContext()); -CREATE_OP_CONTEXT(rel_10_new_Live_op_ctxt,rel_10_new_Live->createContext()); - - #if defined _OPENMP && _OPENMP < 200805 - auto count = std::distance(part.begin(), part.end()); - auto base = part.begin(); - pfor(int index = 0; index < count; index++) { - auto it = base + index; - #else - pfor(auto it = part.begin(); it < part.end(); it++) { - #endif - try{ -for(const auto& env0 : *it) { -auto range = rel_2_Reference->lowerUpperRange_10(Tuple{{ramBitCast(env0[0]), ramBitCast(MIN_RAM_SIGNED)}},Tuple{{ramBitCast(env0[0]), ramBitCast(MAX_RAM_SIGNED)}},READ_OP_CONTEXT(rel_2_Reference_op_ctxt)); -for(const auto& env1 : range) { -if( !(rel_8_Live->contains(Tuple{{ramBitCast(env1[1])}},READ_OP_CONTEXT(rel_8_Live_op_ctxt)))) { -Tuple tuple{{ramBitCast(env1[1])}}; -rel_10_new_Live->insert(tuple,READ_OP_CONTEXT(rel_10_new_Live_op_ctxt)); -} -} -} -} catch(std::exception &e) { signalHandler->error(e.what());} -} -PARALLEL_END -} -();} -if(rel_10_new_Live->empty()) break; -[&](){ -CREATE_OP_CONTEXT(rel_8_Live_op_ctxt,rel_8_Live->createContext()); -CREATE_OP_CONTEXT(rel_10_new_Live_op_ctxt,rel_10_new_Live->createContext()); -for(const auto& env0 : *rel_10_new_Live) { -Tuple tuple{{ramBitCast(env0[0])}}; -rel_8_Live->insert(tuple,READ_OP_CONTEXT(rel_8_Live_op_ctxt)); -} -} -();std::swap(rel_9_delta_Live, rel_10_new_Live); -rel_10_new_Live->purge(); -iter++; -} -iter = 0; -rel_9_delta_Live->purge(); -rel_10_new_Live->purge(); -if (performIO) { -try {std::map directiveMap({{"IO","file"},{"attributeNames","val"},{"auxArity","0"},{"name","Live"},{"operation","output"},{"output-dir","."},{"params","{\"records\": {}, \"relation\": {\"arity\": 1, \"params\": [\"val\"]}}"},{"types","{\"ADTs\": {}, \"records\": {}, \"relation\": {\"arity\": 1, \"types\": [\"s:symbol\"]}}"}}); -if (!outputDirectory.empty()) {directiveMap["output-dir"] = outputDirectory;} -IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_8_Live); -} catch (std::exception& e) {std::cerr << e.what();exit(1);} -} -if (pruneImdtRels) rel_8_Live->purge(); -if (pruneImdtRels) rel_3_LiveStep0->purge(); -if (pruneImdtRels) rel_2_Reference->purge(); -if (pruneImdtRels) rel_7_DeadlockingThread->purge(); -} -#ifdef _MSC_VER -#pragma warning(default: 4100) -#endif // _MSC_VER -}; -SouffleProgram *newInstance_ext_stg_gc(){return new Sf_ext_stg_gc;} -SymbolTable *getST_ext_stg_gc(SouffleProgram *p){return &reinterpret_cast(p)->getSymbolTable();} +in file ext-stg-gc.dl [38:1-40:23])_"); + if (!(rel_delta_Live_2c57e9662e50a2a0->empty()) && !(rel_Reference_c57e388e43703de5->empty())) + { + [&]() + { + CREATE_OP_CONTEXT(rel_delta_Live_2c57e9662e50a2a0_op_ctxt, rel_delta_Live_2c57e9662e50a2a0->createContext()); + CREATE_OP_CONTEXT(rel_new_Live_ca472dbac4201e48_op_ctxt, rel_new_Live_ca472dbac4201e48->createContext()); + CREATE_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt, rel_Live_2818460375647c67->createContext()); + CREATE_OP_CONTEXT(rel_Reference_c57e388e43703de5_op_ctxt, rel_Reference_c57e388e43703de5->createContext()); + for (const auto &env0 : *rel_delta_Live_2c57e9662e50a2a0) + { + auto range = rel_Reference_c57e388e43703de5->lowerUpperRange_10(Tuple{{ramBitCast(env0[0]), ramBitCast(MIN_RAM_SIGNED)}}, Tuple{{ramBitCast(env0[0]), ramBitCast(MAX_RAM_SIGNED)}}, READ_OP_CONTEXT(rel_Reference_c57e388e43703de5_op_ctxt)); + for (const auto &env1 : range) + { + if (!(rel_Live_2818460375647c67->contains(Tuple{{ramBitCast(env1[1])}}, READ_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt)))) + { + Tuple tuple{{ramBitCast(env1[1])}}; + rel_new_Live_ca472dbac4201e48->insert(tuple, READ_OP_CONTEXT(rel_new_Live_ca472dbac4201e48_op_ctxt)); + } + } + } + }(); + } + if (rel_new_Live_ca472dbac4201e48->empty()) + break; + [&]() + { + CREATE_OP_CONTEXT(rel_new_Live_ca472dbac4201e48_op_ctxt, rel_new_Live_ca472dbac4201e48->createContext()); + CREATE_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt, rel_Live_2818460375647c67->createContext()); + for (const auto &env0 : *rel_new_Live_ca472dbac4201e48) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_Live_2818460375647c67->insert(tuple, READ_OP_CONTEXT(rel_Live_2818460375647c67_op_ctxt)); + } + }(); + std::swap(rel_delta_Live_2c57e9662e50a2a0, rel_new_Live_ca472dbac4201e48); + rel_new_Live_ca472dbac4201e48->purge(); + loop_counter = (ramBitCast(loop_counter) + ramBitCast(RamUnsigned(1))); + iter++; + } + iter = 0; + rel_delta_Live_2c57e9662e50a2a0->purge(); + rel_new_Live_ca472dbac4201e48->purge(); + if (performIO) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(val)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(name)_", R"_(Live)_"}, {R"_(operation)_", R"_(output)_"}, {R"_(output-dir)_", R"_(.)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["val"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (outputDirectory == "-") + { + directiveMap["IO"] = "stdout"; + directiveMap["headers"] = "true"; + } + else if (!outputDirectory.empty()) + { + directiveMap["output-dir"] = outputDirectory; + } + IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_Live_2818460375647c67); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + } + if (pruneImdtRels) + rel_LiveStep0_d54eeb7faabc4a13->purge(); + if (pruneImdtRels) + rel_Reference_c57e388e43703de5->purge(); + } -#ifdef __EMBEDDED_SOUFFLE__ -class factory_Sf_ext_stg_gc: public souffle::ProgramFactory { -SouffleProgram *newInstance() { -return new Sf_ext_stg_gc(); -}; -public: -factory_Sf_ext_stg_gc() : ProgramFactory("ext_stg_gc"){} -}; -extern "C" { -factory_Sf_ext_stg_gc __factory_Sf_ext_stg_gc_instance; -} -} -#else -} -int main(int argc, char** argv) +} // namespace souffle + +namespace souffle +{ + using namespace souffle; + class Stratum_LiveStep0_41822abe1018780c + { + public: + Stratum_LiveStep0_41822abe1018780c(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_delta_LiveStep0_749758939b4491e5, t_btree_000_i__0__1::Type &rel_new_LiveStep0_b9970262b9a948e9, t_btree_000_i__0__1::Type &rel_GCRoot_f9754bdf5b76c5df, t_btree_000_i__0__1::Type &rel_LiveStep0_d54eeb7faabc4a13, t_btree_000_ii__0_1__11__10::Type &rel_Reference_c57e388e43703de5); + void run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret); + + private: + SymbolTable &symTable; + RecordTable &recordTable; + ConcurrentCache ®exCache; + bool &pruneImdtRels; + bool &performIO; + SignalHandler *&signalHandler; + std::atomic &iter; + std::atomic &ctr; + std::string &inputDirectory; + std::string &outputDirectory; + t_btree_000_i__0__1::Type *rel_delta_LiveStep0_749758939b4491e5; + t_btree_000_i__0__1::Type *rel_new_LiveStep0_b9970262b9a948e9; + t_btree_000_i__0__1::Type *rel_GCRoot_f9754bdf5b76c5df; + t_btree_000_i__0__1::Type *rel_LiveStep0_d54eeb7faabc4a13; + t_btree_000_ii__0_1__11__10::Type *rel_Reference_c57e388e43703de5; + }; +} // namespace souffle +namespace souffle { -try{ -souffle::CmdOptions opt(R"(ext-stg-gc.dl)", -R"()", -R"()", -false, -R"()", -8); -if (!opt.parse(argc,argv)) return 1; -souffle::Sf_ext_stg_gc obj; -#if defined(_OPENMP) -obj.setNumThreads(opt.getNumJobs()); + using namespace souffle; + Stratum_LiveStep0_41822abe1018780c::Stratum_LiveStep0_41822abe1018780c(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_delta_LiveStep0_749758939b4491e5, t_btree_000_i__0__1::Type &rel_new_LiveStep0_b9970262b9a948e9, t_btree_000_i__0__1::Type &rel_GCRoot_f9754bdf5b76c5df, t_btree_000_i__0__1::Type &rel_LiveStep0_d54eeb7faabc4a13, t_btree_000_ii__0_1__11__10::Type &rel_Reference_c57e388e43703de5) : symTable(symTable), + recordTable(recordTable), + regexCache(regexCache), + pruneImdtRels(pruneImdtRels), + performIO(performIO), + signalHandler(signalHandler), + iter(iter), + ctr(ctr), + inputDirectory(inputDirectory), + outputDirectory(outputDirectory), + rel_delta_LiveStep0_749758939b4491e5(&rel_delta_LiveStep0_749758939b4491e5), + rel_new_LiveStep0_b9970262b9a948e9(&rel_new_LiveStep0_b9970262b9a948e9), + rel_GCRoot_f9754bdf5b76c5df(&rel_GCRoot_f9754bdf5b76c5df), + rel_LiveStep0_d54eeb7faabc4a13(&rel_LiveStep0_d54eeb7faabc4a13), + rel_Reference_c57e388e43703de5(&rel_Reference_c57e388e43703de5) + { + } + void Stratum_LiveStep0_41822abe1018780c::run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret) + { + signalHandler->setMsg(R"_(LiveStep0(ref) :- + GCRoot(ref). +in file ext-stg-gc.dl [18:1-18:31])_"); + if (!(rel_GCRoot_f9754bdf5b76c5df->empty())) + { + [&]() + { + CREATE_OP_CONTEXT(rel_GCRoot_f9754bdf5b76c5df_op_ctxt, rel_GCRoot_f9754bdf5b76c5df->createContext()); + CREATE_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt, rel_LiveStep0_d54eeb7faabc4a13->createContext()); + for (const auto &env0 : *rel_GCRoot_f9754bdf5b76c5df) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_LiveStep0_d54eeb7faabc4a13->insert(tuple, READ_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt)); + } + }(); + } + [&]() + { + CREATE_OP_CONTEXT(rel_delta_LiveStep0_749758939b4491e5_op_ctxt, rel_delta_LiveStep0_749758939b4491e5->createContext()); + CREATE_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt, rel_LiveStep0_d54eeb7faabc4a13->createContext()); + for (const auto &env0 : *rel_LiveStep0_d54eeb7faabc4a13) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_delta_LiveStep0_749758939b4491e5->insert(tuple, READ_OP_CONTEXT(rel_delta_LiveStep0_749758939b4491e5_op_ctxt)); + } + }(); + auto loop_counter = RamUnsigned(1); + iter = 0; + for (;;) + { + signalHandler->setMsg(R"_(LiveStep0(to) :- + LiveStep0(from), + Reference(from,to). +in file ext-stg-gc.dl [20:1-22:23])_"); + if (!(rel_delta_LiveStep0_749758939b4491e5->empty()) && !(rel_Reference_c57e388e43703de5->empty())) + { + [&]() + { + CREATE_OP_CONTEXT(rel_delta_LiveStep0_749758939b4491e5_op_ctxt, rel_delta_LiveStep0_749758939b4491e5->createContext()); + CREATE_OP_CONTEXT(rel_new_LiveStep0_b9970262b9a948e9_op_ctxt, rel_new_LiveStep0_b9970262b9a948e9->createContext()); + CREATE_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt, rel_LiveStep0_d54eeb7faabc4a13->createContext()); + CREATE_OP_CONTEXT(rel_Reference_c57e388e43703de5_op_ctxt, rel_Reference_c57e388e43703de5->createContext()); + for (const auto &env0 : *rel_delta_LiveStep0_749758939b4491e5) + { + auto range = rel_Reference_c57e388e43703de5->lowerUpperRange_10(Tuple{{ramBitCast(env0[0]), ramBitCast(MIN_RAM_SIGNED)}}, Tuple{{ramBitCast(env0[0]), ramBitCast(MAX_RAM_SIGNED)}}, READ_OP_CONTEXT(rel_Reference_c57e388e43703de5_op_ctxt)); + for (const auto &env1 : range) + { + if (!(rel_LiveStep0_d54eeb7faabc4a13->contains(Tuple{{ramBitCast(env1[1])}}, READ_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt)))) + { + Tuple tuple{{ramBitCast(env1[1])}}; + rel_new_LiveStep0_b9970262b9a948e9->insert(tuple, READ_OP_CONTEXT(rel_new_LiveStep0_b9970262b9a948e9_op_ctxt)); + } + } + } + }(); + } + if (rel_new_LiveStep0_b9970262b9a948e9->empty()) + break; + [&]() + { + CREATE_OP_CONTEXT(rel_new_LiveStep0_b9970262b9a948e9_op_ctxt, rel_new_LiveStep0_b9970262b9a948e9->createContext()); + CREATE_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt, rel_LiveStep0_d54eeb7faabc4a13->createContext()); + for (const auto &env0 : *rel_new_LiveStep0_b9970262b9a948e9) + { + Tuple tuple{{ramBitCast(env0[0])}}; + rel_LiveStep0_d54eeb7faabc4a13->insert(tuple, READ_OP_CONTEXT(rel_LiveStep0_d54eeb7faabc4a13_op_ctxt)); + } + }(); + std::swap(rel_delta_LiveStep0_749758939b4491e5, rel_new_LiveStep0_b9970262b9a948e9); + rel_new_LiveStep0_b9970262b9a948e9->purge(); + loop_counter = (ramBitCast(loop_counter) + ramBitCast(RamUnsigned(1))); + iter++; + } + iter = 0; + rel_delta_LiveStep0_749758939b4491e5->purge(); + rel_new_LiveStep0_b9970262b9a948e9->purge(); + if (pruneImdtRels) + rel_GCRoot_f9754bdf5b76c5df->purge(); + } + +} // namespace souffle + +namespace souffle +{ + using namespace souffle; + class Stratum_MaybeDeadlockingThread_fd0c8181097ea422 + { + public: + Stratum_MaybeDeadlockingThread_fd0c8181097ea422(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_MaybeDeadlockingThread_bdb2bd10c95b5982); + void run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret); + + private: + SymbolTable &symTable; + RecordTable &recordTable; + ConcurrentCache ®exCache; + bool &pruneImdtRels; + bool &performIO; + SignalHandler *&signalHandler; + std::atomic &iter; + std::atomic &ctr; + std::string &inputDirectory; + std::string &outputDirectory; + t_btree_000_i__0__1::Type *rel_MaybeDeadlockingThread_bdb2bd10c95b5982; + }; +} // namespace souffle +namespace souffle +{ + using namespace souffle; + Stratum_MaybeDeadlockingThread_fd0c8181097ea422::Stratum_MaybeDeadlockingThread_fd0c8181097ea422(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_i__0__1::Type &rel_MaybeDeadlockingThread_bdb2bd10c95b5982) : symTable(symTable), + recordTable(recordTable), + regexCache(regexCache), + pruneImdtRels(pruneImdtRels), + performIO(performIO), + signalHandler(signalHandler), + iter(iter), + ctr(ctr), + inputDirectory(inputDirectory), + outputDirectory(outputDirectory), + rel_MaybeDeadlockingThread_bdb2bd10c95b5982(&rel_MaybeDeadlockingThread_bdb2bd10c95b5982) + { + } + + void Stratum_MaybeDeadlockingThread_fd0c8181097ea422::run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret) + { + if (performIO) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(threadId)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(fact-dir)_", R"_(.)_"}, {R"_(name)_", R"_(MaybeDeadlockingThread)_"}, {R"_(operation)_", R"_(input)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["threadId"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (!inputDirectory.empty()) + { + directiveMap["fact-dir"] = inputDirectory; + } + IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_MaybeDeadlockingThread_bdb2bd10c95b5982); + } + catch (std::exception &e) + { + std::cerr << "Error loading MaybeDeadlockingThread data: " << e.what() << '\n'; + exit(1); + } + } + } + +} // namespace souffle + +namespace souffle +{ + using namespace souffle; + class Stratum_Reference_374a4e7377ff135c + { + public: + Stratum_Reference_374a4e7377ff135c(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_ii__0_1__11__10::Type &rel_Reference_c57e388e43703de5); + void run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret); + + private: + SymbolTable &symTable; + RecordTable &recordTable; + ConcurrentCache ®exCache; + bool &pruneImdtRels; + bool &performIO; + SignalHandler *&signalHandler; + std::atomic &iter; + std::atomic &ctr; + std::string &inputDirectory; + std::string &outputDirectory; + t_btree_000_ii__0_1__11__10::Type *rel_Reference_c57e388e43703de5; + }; +} // namespace souffle +namespace souffle +{ + using namespace souffle; + Stratum_Reference_374a4e7377ff135c::Stratum_Reference_374a4e7377ff135c(SymbolTable &symTable, RecordTable &recordTable, ConcurrentCache ®exCache, bool &pruneImdtRels, bool &performIO, SignalHandler *&signalHandler, std::atomic &iter, std::atomic &ctr, std::string &inputDirectory, std::string &outputDirectory, t_btree_000_ii__0_1__11__10::Type &rel_Reference_c57e388e43703de5) : symTable(symTable), + recordTable(recordTable), + regexCache(regexCache), + pruneImdtRels(pruneImdtRels), + performIO(performIO), + signalHandler(signalHandler), + iter(iter), + ctr(ctr), + inputDirectory(inputDirectory), + outputDirectory(outputDirectory), + rel_Reference_c57e388e43703de5(&rel_Reference_c57e388e43703de5) + { + } + + void Stratum_Reference_374a4e7377ff135c::run([[maybe_unused]] const std::vector &args, [[maybe_unused]] std::vector &ret) + { + if (performIO) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(from to)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(fact-dir)_", R"_(.)_"}, {R"_(name)_", R"_(Reference)_"}, {R"_(operation)_", R"_(input)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 2, "params": ["from", "to"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 2, "types": ["s:symbol", "s:symbol"]}})_"}}); + if (!inputDirectory.empty()) + { + directiveMap["fact-dir"] = inputDirectory; + } + IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_Reference_c57e388e43703de5); + } + catch (std::exception &e) + { + std::cerr << "Error loading Reference data: " << e.what() << '\n'; + exit(1); + } + } + } + +} // namespace souffle + +namespace souffle +{ + using namespace souffle; + class Sf_ext_stg_gc : public SouffleProgram + { + public: + Sf_ext_stg_gc(); + ~Sf_ext_stg_gc(); + void run(); + void runAll(std::string inputDirectoryArg = "", std::string outputDirectoryArg = "", bool performIOArg = true, bool pruneImdtRelsArg = true); + void printAll([[maybe_unused]] std::string outputDirectoryArg = ""); + void loadAll([[maybe_unused]] std::string inputDirectoryArg = ""); + void dumpInputs(); + void dumpOutputs(); + SymbolTable &getSymbolTable(); + RecordTable &getRecordTable(); + void setNumThreads(std::size_t numThreadsValue); + void executeSubroutine(std::string name, const std::vector &args, std::vector &ret); + + private: + void runFunction(std::string inputDirectoryArg, std::string outputDirectoryArg, bool performIOArg, bool pruneImdtRelsArg); + SymbolTableImpl symTable; + SpecializedRecordTable<0> recordTable; + ConcurrentCache regexCache; + Own rel_GCRoot_f9754bdf5b76c5df; + souffle::RelationWrapper wrapper_rel_GCRoot_f9754bdf5b76c5df; + Own rel_MaybeDeadlockingThread_bdb2bd10c95b5982; + souffle::RelationWrapper wrapper_rel_MaybeDeadlockingThread_bdb2bd10c95b5982; + Own rel_Reference_c57e388e43703de5; + souffle::RelationWrapper wrapper_rel_Reference_c57e388e43703de5; + Own rel_LiveStep0_d54eeb7faabc4a13; + souffle::RelationWrapper wrapper_rel_LiveStep0_d54eeb7faabc4a13; + Own rel_new_LiveStep0_b9970262b9a948e9; + Own rel_delta_LiveStep0_749758939b4491e5; + Own rel_DeadlockingThread_8fa18e0d3ee84b8b; + souffle::RelationWrapper wrapper_rel_DeadlockingThread_8fa18e0d3ee84b8b; + Own rel_Live_2818460375647c67; + souffle::RelationWrapper wrapper_rel_Live_2818460375647c67; + Own rel_new_Live_ca472dbac4201e48; + Own rel_delta_Live_2c57e9662e50a2a0; + Stratum_DeadlockingThread_69894afebfc94aee stratum_DeadlockingThread_18d51e522370d17d; + Stratum_GCRoot_b08a674c48c5fe0e stratum_GCRoot_491c769852c0cbee; + Stratum_Live_b9069971975f423e stratum_Live_20b0d7b68b7a9f85; + Stratum_LiveStep0_41822abe1018780c stratum_LiveStep0_27a7e024cece5ac3; + Stratum_MaybeDeadlockingThread_fd0c8181097ea422 stratum_MaybeDeadlockingThread_83fe8fd8c29c2f3b; + Stratum_Reference_374a4e7377ff135c stratum_Reference_abb7727ac43549af; + std::string inputDirectory; + std::string outputDirectory; + SignalHandler *signalHandler{SignalHandler::instance()}; + std::atomic ctr{}; + std::atomic iter{}; + }; +} // namespace souffle +namespace souffle +{ + using namespace souffle; + Sf_ext_stg_gc::Sf_ext_stg_gc() : symTable(), + recordTable(), + regexCache(), + rel_GCRoot_f9754bdf5b76c5df(mk()), + wrapper_rel_GCRoot_f9754bdf5b76c5df(0, *rel_GCRoot_f9754bdf5b76c5df, *this, "GCRoot", std::array{{"s:symbol"}}, std::array{{"val"}}, 0), + rel_MaybeDeadlockingThread_bdb2bd10c95b5982(mk()), + wrapper_rel_MaybeDeadlockingThread_bdb2bd10c95b5982(1, *rel_MaybeDeadlockingThread_bdb2bd10c95b5982, *this, "MaybeDeadlockingThread", std::array{{"s:symbol"}}, std::array{{"threadId"}}, 0), + rel_Reference_c57e388e43703de5(mk()), + wrapper_rel_Reference_c57e388e43703de5(2, *rel_Reference_c57e388e43703de5, *this, "Reference", std::array{{"s:symbol", "s:symbol"}}, std::array{{"from", "to"}}, 0), + rel_LiveStep0_d54eeb7faabc4a13(mk()), + wrapper_rel_LiveStep0_d54eeb7faabc4a13(3, *rel_LiveStep0_d54eeb7faabc4a13, *this, "LiveStep0", std::array{{"s:symbol"}}, std::array{{"val"}}, 0), + rel_new_LiveStep0_b9970262b9a948e9(mk()), + rel_delta_LiveStep0_749758939b4491e5(mk()), + rel_DeadlockingThread_8fa18e0d3ee84b8b(mk()), + wrapper_rel_DeadlockingThread_8fa18e0d3ee84b8b(4, *rel_DeadlockingThread_8fa18e0d3ee84b8b, *this, "DeadlockingThread", std::array{{"s:symbol"}}, std::array{{"threadId"}}, 0), + rel_Live_2818460375647c67(mk()), + wrapper_rel_Live_2818460375647c67(5, *rel_Live_2818460375647c67, *this, "Live", std::array{{"s:symbol"}}, std::array{{"val"}}, 0), + rel_new_Live_ca472dbac4201e48(mk()), + rel_delta_Live_2c57e9662e50a2a0(mk()), + stratum_DeadlockingThread_18d51e522370d17d(symTable, recordTable, regexCache, pruneImdtRels, performIO, signalHandler, iter, ctr, inputDirectory, outputDirectory, *rel_DeadlockingThread_8fa18e0d3ee84b8b, *rel_LiveStep0_d54eeb7faabc4a13, *rel_MaybeDeadlockingThread_bdb2bd10c95b5982), + stratum_GCRoot_491c769852c0cbee(symTable, recordTable, regexCache, pruneImdtRels, performIO, signalHandler, iter, ctr, inputDirectory, outputDirectory, *rel_GCRoot_f9754bdf5b76c5df), + stratum_Live_20b0d7b68b7a9f85(symTable, recordTable, regexCache, pruneImdtRels, performIO, signalHandler, iter, ctr, inputDirectory, outputDirectory, *rel_delta_Live_2c57e9662e50a2a0, *rel_new_Live_ca472dbac4201e48, *rel_DeadlockingThread_8fa18e0d3ee84b8b, *rel_Live_2818460375647c67, *rel_LiveStep0_d54eeb7faabc4a13, *rel_Reference_c57e388e43703de5), + stratum_LiveStep0_27a7e024cece5ac3(symTable, recordTable, regexCache, pruneImdtRels, performIO, signalHandler, iter, ctr, inputDirectory, outputDirectory, *rel_delta_LiveStep0_749758939b4491e5, *rel_new_LiveStep0_b9970262b9a948e9, *rel_GCRoot_f9754bdf5b76c5df, *rel_LiveStep0_d54eeb7faabc4a13, *rel_Reference_c57e388e43703de5), + stratum_MaybeDeadlockingThread_83fe8fd8c29c2f3b(symTable, recordTable, regexCache, pruneImdtRels, performIO, signalHandler, iter, ctr, inputDirectory, outputDirectory, *rel_MaybeDeadlockingThread_bdb2bd10c95b5982), + stratum_Reference_abb7727ac43549af(symTable, recordTable, regexCache, pruneImdtRels, performIO, signalHandler, iter, ctr, inputDirectory, outputDirectory, *rel_Reference_c57e388e43703de5) + { + addRelation("GCRoot", wrapper_rel_GCRoot_f9754bdf5b76c5df, true, false); + addRelation("MaybeDeadlockingThread", wrapper_rel_MaybeDeadlockingThread_bdb2bd10c95b5982, true, false); + addRelation("Reference", wrapper_rel_Reference_c57e388e43703de5, true, false); + addRelation("LiveStep0", wrapper_rel_LiveStep0_d54eeb7faabc4a13, false, false); + addRelation("DeadlockingThread", wrapper_rel_DeadlockingThread_8fa18e0d3ee84b8b, false, true); + addRelation("Live", wrapper_rel_Live_2818460375647c67, false, true); + } + + Sf_ext_stg_gc::~Sf_ext_stg_gc() + { + } + + void Sf_ext_stg_gc::runFunction(std::string inputDirectoryArg, std::string outputDirectoryArg, bool performIOArg, bool pruneImdtRelsArg) + { + + this->inputDirectory = std::move(inputDirectoryArg); + this->outputDirectory = std::move(outputDirectoryArg); + this->performIO = performIOArg; + this->pruneImdtRels = pruneImdtRelsArg; + + // set default threads (in embedded mode) + // if this is not set, and omp is used, the default omp setting of number of cores is used. +#if defined(_OPENMP) + if (0 < getNumThreads()) + { + omp_set_num_threads(static_cast(getNumThreads())); + } #endif -obj.runAll(opt.getInputFileDir(), opt.getOutputFileDir()); -return 0; -} catch(std::exception &e) { souffle::SignalHandler::instance()->error(e.what());} + + signalHandler->set(); + // -- query evaluation -- + { + std::vector args, ret; + stratum_GCRoot_491c769852c0cbee.run(args, ret); + } + { + std::vector args, ret; + stratum_MaybeDeadlockingThread_83fe8fd8c29c2f3b.run(args, ret); + } + { + std::vector args, ret; + stratum_Reference_abb7727ac43549af.run(args, ret); + } + { + std::vector args, ret; + stratum_LiveStep0_27a7e024cece5ac3.run(args, ret); + } + { + std::vector args, ret; + stratum_DeadlockingThread_18d51e522370d17d.run(args, ret); + } + { + std::vector args, ret; + stratum_Live_20b0d7b68b7a9f85.run(args, ret); + } + + // -- relation hint statistics -- + signalHandler->reset(); + } + + void Sf_ext_stg_gc::run() + { + runFunction("", "", false, false); + } + + void Sf_ext_stg_gc::runAll(std::string inputDirectoryArg, std::string outputDirectoryArg, bool performIOArg, bool pruneImdtRelsArg) + { + runFunction(inputDirectoryArg, outputDirectoryArg, performIOArg, pruneImdtRelsArg); + } + + void Sf_ext_stg_gc::printAll([[maybe_unused]] std::string outputDirectoryArg) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(threadId)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(name)_", R"_(DeadlockingThread)_"}, {R"_(operation)_", R"_(output)_"}, {R"_(output-dir)_", R"_(.)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["threadId"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (!outputDirectoryArg.empty()) + { + directiveMap["output-dir"] = outputDirectoryArg; + } + IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_DeadlockingThread_8fa18e0d3ee84b8b); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(val)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(name)_", R"_(Live)_"}, {R"_(operation)_", R"_(output)_"}, {R"_(output-dir)_", R"_(.)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["val"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (!outputDirectoryArg.empty()) + { + directiveMap["output-dir"] = outputDirectoryArg; + } + IOSystem::getInstance().getWriter(directiveMap, symTable, recordTable)->writeAll(*rel_Live_2818460375647c67); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + } + + void Sf_ext_stg_gc::loadAll([[maybe_unused]] std::string inputDirectoryArg) + { + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(val)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(fact-dir)_", R"_(.)_"}, {R"_(name)_", R"_(GCRoot)_"}, {R"_(operation)_", R"_(input)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["val"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (!inputDirectoryArg.empty()) + { + directiveMap["fact-dir"] = inputDirectoryArg; + } + IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_GCRoot_f9754bdf5b76c5df); + } + catch (std::exception &e) + { + std::cerr << "Error loading GCRoot data: " << e.what() << '\n'; + exit(1); + } + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(threadId)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(fact-dir)_", R"_(.)_"}, {R"_(name)_", R"_(MaybeDeadlockingThread)_"}, {R"_(operation)_", R"_(input)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 1, "params": ["threadId"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 1, "types": ["s:symbol"]}})_"}}); + if (!inputDirectoryArg.empty()) + { + directiveMap["fact-dir"] = inputDirectoryArg; + } + IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_MaybeDeadlockingThread_bdb2bd10c95b5982); + } + catch (std::exception &e) + { + std::cerr << "Error loading MaybeDeadlockingThread data: " << e.what() << '\n'; + exit(1); + } + try + { + std::map directiveMap({{R"_(IO)_", R"_(file)_"}, {R"_(attributeNames)_", R"_(from to)_"}, {R"_(auxArity)_", R"_(0)_"}, {R"_(fact-dir)_", R"_(.)_"}, {R"_(name)_", R"_(Reference)_"}, {R"_(operation)_", R"_(input)_"}, {R"_(params)_", R"_({"records": {}, "relation": {"arity": 2, "params": ["from", "to"]}})_"}, {R"_(types)_", R"_({"ADTs": {}, "records": {}, "relation": {"arity": 2, "types": ["s:symbol", "s:symbol"]}})_"}}); + if (!inputDirectoryArg.empty()) + { + directiveMap["fact-dir"] = inputDirectoryArg; + } + IOSystem::getInstance().getReader(directiveMap, symTable, recordTable)->readAll(*rel_Reference_c57e388e43703de5); + } + catch (std::exception &e) + { + std::cerr << "Error loading Reference data: " << e.what() << '\n'; + exit(1); + } + } + + void Sf_ext_stg_gc::dumpInputs() + { + try + { + std::map rwOperation; + rwOperation["IO"] = "stdout"; + rwOperation["name"] = "GCRoot"; + rwOperation["types"] = R"_({"relation": {"arity": 1, "auxArity": 0, "types": ["s:symbol"]}})_"; + IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_GCRoot_f9754bdf5b76c5df); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + try + { + std::map rwOperation; + rwOperation["IO"] = "stdout"; + rwOperation["name"] = "MaybeDeadlockingThread"; + rwOperation["types"] = R"_({"relation": {"arity": 1, "auxArity": 0, "types": ["s:symbol"]}})_"; + IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_MaybeDeadlockingThread_bdb2bd10c95b5982); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + try + { + std::map rwOperation; + rwOperation["IO"] = "stdout"; + rwOperation["name"] = "Reference"; + rwOperation["types"] = R"_({"relation": {"arity": 2, "auxArity": 0, "types": ["s:symbol", "s:symbol"]}})_"; + IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_Reference_c57e388e43703de5); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + } + + void Sf_ext_stg_gc::dumpOutputs() + { + try + { + std::map rwOperation; + rwOperation["IO"] = "stdout"; + rwOperation["name"] = "DeadlockingThread"; + rwOperation["types"] = R"_({"relation": {"arity": 1, "auxArity": 0, "types": ["s:symbol"]}})_"; + IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_DeadlockingThread_8fa18e0d3ee84b8b); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + try + { + std::map rwOperation; + rwOperation["IO"] = "stdout"; + rwOperation["name"] = "Live"; + rwOperation["types"] = R"_({"relation": {"arity": 1, "auxArity": 0, "types": ["s:symbol"]}})_"; + IOSystem::getInstance().getWriter(rwOperation, symTable, recordTable)->writeAll(*rel_Live_2818460375647c67); + } + catch (std::exception &e) + { + std::cerr << e.what(); + exit(1); + } + } + + SymbolTable &Sf_ext_stg_gc::getSymbolTable() + { + return symTable; + } + + RecordTable &Sf_ext_stg_gc::getRecordTable() + { + return recordTable; + } + + void Sf_ext_stg_gc::setNumThreads(std::size_t numThreadsValue) + { + SouffleProgram::setNumThreads(numThreadsValue); + symTable.setNumLanes(getNumThreads()); + recordTable.setNumLanes(getNumThreads()); + regexCache.setNumLanes(getNumThreads()); + } + + void Sf_ext_stg_gc::executeSubroutine(std::string name, const std::vector &args, std::vector &ret) + { + if (name == "DeadlockingThread") + { + stratum_DeadlockingThread_18d51e522370d17d.run(args, ret); + return; + } + if (name == "GCRoot") + { + stratum_GCRoot_491c769852c0cbee.run(args, ret); + return; + } + if (name == "Live") + { + stratum_Live_20b0d7b68b7a9f85.run(args, ret); + return; + } + if (name == "LiveStep0") + { + stratum_LiveStep0_27a7e024cece5ac3.run(args, ret); + return; + } + if (name == "MaybeDeadlockingThread") + { + stratum_MaybeDeadlockingThread_83fe8fd8c29c2f3b.run(args, ret); + return; + } + if (name == "Reference") + { + stratum_Reference_abb7727ac43549af.run(args, ret); + return; + } + fatal(("unknown subroutine " + name).c_str()); + } + +} // namespace souffle +namespace souffle +{ + SouffleProgram *newInstance_ext_stg_gc() { return new souffle::Sf_ext_stg_gc; } + SymbolTable *getST_ext_stg_gc(SouffleProgram *p) { return &reinterpret_cast(p)->getSymbolTable(); } +} // namespace souffle + +#ifndef __EMBEDDED_SOUFFLE__ +#include "souffle/CompiledOptions.h" +int main(int argc, char **argv) +{ + try + { + souffle::CmdOptions opt(R"_(datalog/ext-stg-gc.dl)_", + R"_()_", + R"_()_", + false, + R"_()_", + 1); + if (!opt.parse(argc, argv)) + return 1; + souffle::Sf_ext_stg_gc obj; +#if defined(_OPENMP) + obj.setNumThreads(opt.getNumJobs()); + +#endif + obj.runAll(opt.getInputFileDir(), opt.getOutputFileDir()); + return 0; + } + catch (std::exception &e) + { + souffle::SignalHandler::instance()->error(e.what()); + } } +#endif +namespace souffle +{ + using namespace souffle; + class factory_Sf_ext_stg_gc : souffle::ProgramFactory + { + public: + souffle::SouffleProgram *newInstance(); + factory_Sf_ext_stg_gc(); + + private: + }; +} // namespace souffle +namespace souffle +{ + using namespace souffle; + souffle::SouffleProgram *factory_Sf_ext_stg_gc::newInstance() + { + return new souffle::Sf_ext_stg_gc(); + } + + factory_Sf_ext_stg_gc::factory_Sf_ext_stg_gc() : souffle::ProgramFactory("ext_stg_gc") + { + } + +} // namespace souffle +namespace souffle +{ + +#ifdef __EMBEDDED_SOUFFLE__ + extern "C" + { + souffle::factory_Sf_ext_stg_gc __factory_Sf_ext_stg_gc_instance; + } #endif +} // namespace souffle diff --git a/external-stg-interpreter/external-stg-interpreter.cabal b/external-stg-interpreter/external-stg-interpreter.cabal index 06d49d1..a620ec1 100644 --- a/external-stg-interpreter/external-stg-interpreter.cabal +++ b/external-stg-interpreter/external-stg-interpreter.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.14 name: external-stg-interpreter version: 0.1.0.1 synopsis: External STG interpreter @@ -11,35 +11,104 @@ copyright: (c) 2020 Csaba Hruska category: Development build-type: Simple +data-files: + datalog/*.dl + datalog/**/*.dl + +extra-source-files: + souffle/src/include/souffle/*.h + souffle/src/include/souffle/**/*.h + souffle/src/include/souffle/swig/SwigInterface.i + +common lang + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards + ghc-options: + -Wall + -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Widentities + -Wunused-packages + -Wmissing-deriving-strategies + library + hs-source-dirs: lib + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + MultiWayIf + NoImplicitPrelude + OverloadedStrings + PatternSynonyms + RecordWildCards + TypeFamilies + ghc-options: + -Wall + -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -- -Wredundant-constraints + -Widentities + -Wunused-packages + -Wmissing-deriving-strategies + ghc-options: -fobject-code -O2 + build-depends: + base, + bimap, + bytestring, + containers, + directory, + external-stg, + external-stg-syntax, + filepath, + inline-c, + libffi, + mtl, + pretty-simple, + pretty-terminal, + primitive, + souffle-haskell, + text, + time, + transformers, + unagi-chan, + unix, + vector, + yaml, + zip exposed-modules: Foreign.LibFFI.Closure Stg.Interpreter Stg.Interpreter.Base - Stg.Interpreter.FFI - Stg.Interpreter.PrimCall - Stg.Interpreter.Rts - Stg.Interpreter.RtsFFI - Stg.Interpreter.EmulatedLibFFI Stg.Interpreter.Debug - Stg.Interpreter.IOManager - Stg.Interpreter.ThreadScheduler Stg.Interpreter.Debugger Stg.Interpreter.Debugger.Datalog Stg.Interpreter.Debugger.Internal Stg.Interpreter.Debugger.Region - Stg.Interpreter.Debugger.UI - Stg.Interpreter.Debugger.TraverseState Stg.Interpreter.Debugger.Retainer + Stg.Interpreter.Debugger.TraverseState + Stg.Interpreter.Debugger.UI + Stg.Interpreter.EmulatedLibFFI + Stg.Interpreter.FFI Stg.Interpreter.GC + Stg.Interpreter.GC.DeadlockAnalysis Stg.Interpreter.GC.GCRef Stg.Interpreter.GC.LiveDataAnalysis Stg.Interpreter.GC.RetainerAnalysis - Stg.Interpreter.GC.DeadlockAnalysis + Stg.Interpreter.IOManager + Stg.Interpreter.PrimCall Stg.Interpreter.PrimOp.Addr - Stg.Interpreter.PrimOp.ArrayArray Stg.Interpreter.PrimOp.Array + Stg.Interpreter.PrimOp.ArrayArray Stg.Interpreter.PrimOp.ByteArray Stg.Interpreter.PrimOp.Char Stg.Interpreter.PrimOp.Compact @@ -50,126 +119,97 @@ library Stg.Interpreter.PrimOp.Float Stg.Interpreter.PrimOp.GHCiBytecode Stg.Interpreter.PrimOp.InfoTableOrigin - Stg.Interpreter.PrimOp.Int64 - Stg.Interpreter.PrimOp.Int32 + Stg.Interpreter.PrimOp.Int Stg.Interpreter.PrimOp.Int16 + Stg.Interpreter.PrimOp.Int32 + Stg.Interpreter.PrimOp.Int64 Stg.Interpreter.PrimOp.Int8 - Stg.Interpreter.PrimOp.Int + Stg.Interpreter.PrimOp.MVar Stg.Interpreter.PrimOp.MiscEtc Stg.Interpreter.PrimOp.MutVar - Stg.Interpreter.PrimOp.MVar Stg.Interpreter.PrimOp.Narrowings Stg.Interpreter.PrimOp.ObjectLifetime Stg.Interpreter.PrimOp.Parallelism Stg.Interpreter.PrimOp.Prefetch + Stg.Interpreter.PrimOp.STM Stg.Interpreter.PrimOp.SmallArray Stg.Interpreter.PrimOp.StablePointer - Stg.Interpreter.PrimOp.STM Stg.Interpreter.PrimOp.TagToEnum Stg.Interpreter.PrimOp.Unsafe Stg.Interpreter.PrimOp.WeakPointer - Stg.Interpreter.PrimOp.Word64 - Stg.Interpreter.PrimOp.Word32 + Stg.Interpreter.PrimOp.Word Stg.Interpreter.PrimOp.Word16 + Stg.Interpreter.PrimOp.Word32 + Stg.Interpreter.PrimOp.Word64 Stg.Interpreter.PrimOp.Word8 - Stg.Interpreter.PrimOp.Word - - hs-source-dirs: lib - ghc-options: -Wall -fobject-code -O2 - build-depends: base, - time, - unix, - filepath, - directory, - libffi, - zip, - yaml, - text, - bytestring, - containers, - primitive, - vector, - mtl, - inline-c, - unagi-chan, - pretty-terminal, - pretty-simple, - dom-lt, - bimap, - souffle-haskell, - external-stg-syntax, - external-stg - default-language: Haskell2010 - - include-dirs: datalog - + Stg.Interpreter.Rts + Stg.Interpreter.RtsFFI + Stg.Interpreter.ThreadScheduler + + include-dirs: + datalog + souffle/src/include + cxx-options: -D__EMBEDDED_SOUFFLE__ -std=c++17 -Wno-deprecated-declarations + cxx-sources: datalog/ext-stg-gc.cpp - cxx-sources: datalog/ext-stg-gc.cpp - cxx-options: -D__EMBEDDED_SOUFFLE__ -D_OPENMP -std=c++17 - if os(darwin) - ld-options: "-Wl,-all_load" - extra-libraries: omp stdc++ - else - ld-options: "-Wl,-u,__factory_Sf_ext_stg_gc_instance" - extra-libraries: gomp executable ext-stg-interpreter - default-language: Haskell2010 - hs-source-dirs: app - main-is: ExtStgInterpreter.hs - build-depends: base < 5.0, - containers, - bytestring, - unagi-chan, - unix, - shellwords, - optparse-applicative, - external-stg, - external-stg-interpreter - + import: lang + hs-source-dirs: app + main-is: ExtStgInterpreter.hs + build-depends: + base < 5.0, + external-stg-interpreter, + optparse-applicative, + shellwords, + unagi-chan + include-dirs: + datalog + souffle/src/include + cxx-options: -D__EMBEDDED_SOUFFLE__ -std=c++17 -Wno-deprecated-declarations + cxx-sources: datalog/ext-stg-gc.cpp ghc-options: -rtsopts -threaded executable run-stgi-testsuite - default-language: Haskell2010 - hs-source-dirs: app - main-is: RunStgiTestsuite.hs - build-depends: base < 5.0, - containers, - filepath, - directory, - bytestring, - ansi-wl-pprint, - timeit, - filemanip, - async-pool, - process - + import: lang + hs-source-dirs: app + main-is: RunStgiTestsuite.hs + build-depends: + async-pool, + base < 5.0, + bytestring, + containers, + directory, + filemanip, + filepath, + prettyprinter, + prettyprinter-ansi-terminal, + process, + timeit ghc-options: -rtsopts -threaded test-suite primop-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - default-extensions: OverloadedStrings - build-depends: base >=4.11 - , mtl - , external-stg - , external-stg-syntax - , external-stg-interpreter - , hspec - , hspec-core - , hspec-discover - , QuickCheck + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base >=4.11, + external-stg-interpreter, + external-stg-syntax, + hspec, + mtl, + QuickCheck - other-modules: PrimOp.Word8Spec - PrimOp.Word16Spec - PrimOp.IntSpec - PrimOp.Int8Spec - PrimOp.Int16Spec - PrimOp.CharSpec - PrimOp.NarrowingsSpec - PrimOp.FloatSpec - PrimOp.DoubleSpec - PrimOp.WordSpec - PrimOp.AddrSpec + other-modules: + PrimOp.AddrSpec + PrimOp.CharSpec + PrimOp.DoubleSpec + PrimOp.FloatSpec + PrimOp.Int16Spec + PrimOp.Int8Spec + PrimOp.IntSpec + PrimOp.NarrowingsSpec + PrimOp.Word16Spec + PrimOp.Word8Spec + PrimOp.WordSpec diff --git a/external-stg-interpreter/hie.yaml b/external-stg-interpreter/hie.yaml new file mode 100644 index 0000000..70240cc --- /dev/null +++ b/external-stg-interpreter/hie.yaml @@ -0,0 +1,13 @@ +cradle: + cabal: + - path: "lib" + component: "lib:external-stg-interpreter" + + - path: "app/ExtStgInterpreter.hs" + component: "external-stg-interpreter:exe:ext-stg-interpreter" + + - path: "app/RunStgiTestsuite.hs" + component: "external-stg-interpreter:exe:run-stgi-testsuite" + + - path: "test" + component: "external-stg-interpreter:test:primop-test" diff --git a/external-stg-interpreter/lib/Foreign/LibFFI/Closure.hsc b/external-stg-interpreter/lib/Foreign/LibFFI/Closure.hsc index 08a8b82..1737bf8 100644 --- a/external-stg-interpreter/lib/Foreign/LibFFI/Closure.hsc +++ b/external-stg-interpreter/lib/Foreign/LibFFI/Closure.hsc @@ -1,4 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving #-} {- | The internals of the C library libffi -} module Foreign.LibFFI.Closure where @@ -14,7 +13,15 @@ import Data.Word import Control.Monad import Foreign.Marshal.Alloc import Foreign.Marshal.Array -import Data.List (genericLength) +import System.IO +import Data.Int +import Data.Eq +import Text.Show +import Data.Function +import Control.Applicative +import Data.List +import Data.Ord +import GHC.Err -- low level API @@ -28,7 +35,8 @@ foreign import ccall "wrapper" wrap_FFI_Impl :: FFI_Impl -> IO (FunPtr FFI_Impl) foreign import ccall ffi_prep_closure_loc :: Closure -> Ptr CIF -> FunPtr FFI_Impl -> Ptr Word8 -> Entry -> IO C_ffi_status newtype Closure = Closure (Ptr Closure) -newtype Entry = Entry (FunPtr Entry) deriving (Eq, Ord, Show, Storable) +newtype Entry = Entry (FunPtr Entry) + deriving newtype (Eq, Ord, Show, Storable) foreign import ccall ffi_closure_alloc :: Int -> Ptr Entry -> IO Closure foreign import ccall ffi_closure_free :: Closure -> IO () diff --git a/external-stg-interpreter/lib/Stg/Interpreter.hs b/external-stg-interpreter/lib/Stg/Interpreter.hs index ce30a44..9258a69 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter.hs @@ -1,94 +1,127 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} -{-# LANGUAGE ForeignFunctionInterface #-} module Stg.Interpreter where -import GHC.Stack -import qualified GHC.Exts as Exts -import Foreign.Ptr - -import Control.Concurrent -import Control.Concurrent.MVar -import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi -import Control.Monad.State.Strict -import Control.Exception -import qualified Data.Primitive.ByteArray as BA - -import Data.Maybe -import Data.List (partition, isSuffixOf) -import Data.Set (Set) -import Data.Map (Map) -import qualified Data.Map.Strict as StrictMap -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Internal as BS -import System.Posix.DynamicLinker -import Codec.Archive.Zip -import qualified Data.Yaml as Y - -import Data.Time.Clock - -import System.FilePath -import System.IO -import System.Directory -import System.Exit - -import Stg.IRLocation -import Stg.Syntax -import Stg.IO -import Stg.Program -import Stg.JSON -import Stg.Analysis.LiveVariable -import Stg.Foreign.Linker - -import Stg.Interpreter.Base -import Stg.Interpreter.PrimCall -import Stg.Interpreter.FFI -import Stg.Interpreter.Rts -import Stg.Interpreter.Debug -import qualified Stg.Interpreter.ThreadScheduler as Scheduler -import qualified Stg.Interpreter.Debugger as Debugger -import qualified Stg.Interpreter.Debugger.Region as Debugger -import qualified Stg.Interpreter.Debugger.Internal as Debugger -import qualified Stg.Interpreter.GC as GC - -import qualified Stg.Interpreter.PrimOp.Addr as PrimAddr -import qualified Stg.Interpreter.PrimOp.Array as PrimArray -import qualified Stg.Interpreter.PrimOp.SmallArray as PrimSmallArray -import qualified Stg.Interpreter.PrimOp.ArrayArray as PrimArrayArray -import qualified Stg.Interpreter.PrimOp.ByteArray as PrimByteArray -import qualified Stg.Interpreter.PrimOp.Char as PrimChar -import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency -import qualified Stg.Interpreter.PrimOp.DelayWait as PrimDelayWait -import qualified Stg.Interpreter.PrimOp.Parallelism as PrimParallelism -import qualified Stg.Interpreter.PrimOp.Exceptions as PrimExceptions -import qualified Stg.Interpreter.PrimOp.Float as PrimFloat -import qualified Stg.Interpreter.PrimOp.Double as PrimDouble -import qualified Stg.Interpreter.PrimOp.Word as PrimWord -import qualified Stg.Interpreter.PrimOp.Word8 as PrimWord8 -import qualified Stg.Interpreter.PrimOp.Word16 as PrimWord16 -import qualified Stg.Interpreter.PrimOp.Word32 as PrimWord32 -import qualified Stg.Interpreter.PrimOp.Word64 as PrimWord64 -import qualified Stg.Interpreter.PrimOp.Int as PrimInt -import qualified Stg.Interpreter.PrimOp.Int8 as PrimInt8 -import qualified Stg.Interpreter.PrimOp.Int16 as PrimInt16 -import qualified Stg.Interpreter.PrimOp.Int32 as PrimInt32 -import qualified Stg.Interpreter.PrimOp.Int64 as PrimInt64 -import qualified Stg.Interpreter.PrimOp.MutVar as PrimMutVar -import qualified Stg.Interpreter.PrimOp.MVar as PrimMVar -import qualified Stg.Interpreter.PrimOp.Narrowings as PrimNarrowings -import qualified Stg.Interpreter.PrimOp.Prefetch as PrimPrefetch -import qualified Stg.Interpreter.PrimOp.StablePointer as PrimStablePointer -import qualified Stg.Interpreter.PrimOp.STM as PrimSTM -import qualified Stg.Interpreter.PrimOp.WeakPointer as PrimWeakPointer -import qualified Stg.Interpreter.PrimOp.TagToEnum as PrimTagToEnum -import qualified Stg.Interpreter.PrimOp.Unsafe as PrimUnsafe -import qualified Stg.Interpreter.PrimOp.MiscEtc as PrimMiscEtc -import qualified Stg.Interpreter.PrimOp.ObjectLifetime as PrimObjectLifetime +import Codec.Archive.Zip (mkEntrySelector, saveEntry, withArchive) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.Concurrent (killThread, newEmptyMVar) +import Control.Exception (SomeException, handle, throw) +import Control.Monad (Functor (..), Monad (..), forM, forM_, mapM, mapM_, unless, + void, when) +import Control.Monad.State.Strict (MonadIO (..), StateT, execStateT, gets, modify') + +import Data.Bool (Bool (..), not, otherwise, (&&), (||)) +import Data.Eq (Eq (..)) +import Data.Function (id, ($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.List (concatMap, elem, isSuffixOf, length, null, partition, reverse, + splitAt, unzip, zip, (++)) +import qualified Data.Map as Map +import qualified Data.Map.Strict as StrictMap +import Data.Maybe (Maybe (..), maybe) +import Data.Monoid (Monoid (..)) +import Data.Ord (Ord (..)) +import qualified Data.Set as Set +import Data.String (String) +import Data.Time.Clock (getCurrentTime) +import qualified Data.Yaml as Y + +import Foreign.Ptr (nullPtr) + +import GHC.Err (error, undefined) +import GHC.Num (Num (..)) +import GHC.Real (fromIntegral, realToFrac) +import GHC.Stack (HasCallStack) + +import Prelude (Enum (..)) + +import Stg.Analysis.LiveVariable (annotateWithLiveVariables) +import Stg.Foreign.Linker (getExtStgWorkDirectory, linkForeignCbitsSharedLib) +import Stg.Interpreter.Base (Addr, Atom (..), BlockReason (..), Breakpoint (..), + CallGraph (..), CutShow (..), DebugFrame (..), DebugSettings, + DebugState (..), DebuggerChan, Env, HeapObject (..), M, + Printable (..), PrintableMVar (..), ProgramPoint (..), + PtrOrigin (..), Rts (..), ScheduleReason (..), + StackContinuation (..), StaticOrigin (..), StgState (..), + ThreadState (..), ThreadStatus (..), TracingState (..), + addBinderToEnv, addInterClosureCallGraphEdge, + addIntraClosureCallGraphEdge, addManyBindersToEnv, + addZippedBindersToEnv, allocAndStore, createThread, + debugPrintAtom, debugPrintHeapObject, emptyStgState, + envToAtoms, freshHeapAddress, getCStringConstantPtrAtom, + getCurrentThreadState, getThreadState, isThreadLive, lookupEnv, + lookupEnvSO, markClosure, markExecuted, markExecutedId, + markFFI, markLNE, markPrimCall, markPrimOp, mylog, promptM, + readHeap, readHeapCon, reportThreads, scheduleToTheEnd, + setProgramPoint, showStackCont, stackPop, stackPush, stgErrorM, + store, switchToThread, traceLog, updateThreadState, + wakeupBlackHoleQueueThreads) +import Stg.Interpreter.Debug (exportCallGraph) +import qualified Stg.Interpreter.Debugger as Debugger +import qualified Stg.Interpreter.Debugger.Region as Debugger +import Stg.Interpreter.FFI (buildCWrapperHsTypeMap, evalFCallOp, getFFILabelPtrAtom) +import qualified Stg.Interpreter.GC as GC +import Stg.Interpreter.PrimCall (evalPrimCallOp) +import qualified Stg.Interpreter.PrimOp.Addr as PrimAddr +import qualified Stg.Interpreter.PrimOp.Array as PrimArray +import qualified Stg.Interpreter.PrimOp.ArrayArray as PrimArrayArray +import qualified Stg.Interpreter.PrimOp.ByteArray as PrimByteArray +import qualified Stg.Interpreter.PrimOp.Char as PrimChar +import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency +import qualified Stg.Interpreter.PrimOp.DelayWait as PrimDelayWait +import qualified Stg.Interpreter.PrimOp.Double as PrimDouble +import qualified Stg.Interpreter.PrimOp.Exceptions as PrimExceptions +import qualified Stg.Interpreter.PrimOp.Float as PrimFloat import qualified Stg.Interpreter.PrimOp.InfoTableOrigin as PrimInfoTableOrigin +import qualified Stg.Interpreter.PrimOp.Int as PrimInt +import qualified Stg.Interpreter.PrimOp.Int16 as PrimInt16 +import qualified Stg.Interpreter.PrimOp.Int32 as PrimInt32 +import qualified Stg.Interpreter.PrimOp.Int64 as PrimInt64 +import qualified Stg.Interpreter.PrimOp.Int8 as PrimInt8 +import qualified Stg.Interpreter.PrimOp.MiscEtc as PrimMiscEtc +import qualified Stg.Interpreter.PrimOp.MutVar as PrimMutVar +import qualified Stg.Interpreter.PrimOp.MVar as PrimMVar +import qualified Stg.Interpreter.PrimOp.Narrowings as PrimNarrowings +import qualified Stg.Interpreter.PrimOp.ObjectLifetime as PrimObjectLifetime +import qualified Stg.Interpreter.PrimOp.Parallelism as PrimParallelism +import qualified Stg.Interpreter.PrimOp.Prefetch as PrimPrefetch +import qualified Stg.Interpreter.PrimOp.SmallArray as PrimSmallArray +import qualified Stg.Interpreter.PrimOp.StablePointer as PrimStablePointer +import qualified Stg.Interpreter.PrimOp.STM as PrimSTM +import qualified Stg.Interpreter.PrimOp.TagToEnum as PrimTagToEnum +import qualified Stg.Interpreter.PrimOp.Unsafe as PrimUnsafe +import qualified Stg.Interpreter.PrimOp.WeakPointer as PrimWeakPointer +import qualified Stg.Interpreter.PrimOp.Word as PrimWord +import qualified Stg.Interpreter.PrimOp.Word16 as PrimWord16 +import qualified Stg.Interpreter.PrimOp.Word32 as PrimWord32 +import qualified Stg.Interpreter.PrimOp.Word64 as PrimWord64 +import qualified Stg.Interpreter.PrimOp.Word8 as PrimWord8 +import Stg.Interpreter.Rts (extStgRtsSupportModule, initRtsSupport) +import qualified Stg.Interpreter.ThreadScheduler as Scheduler +import Stg.IO (readModpakS) +import Stg.IRLocation (StgPoint (..), binderToStgId) +import Stg.Program (GhcStgApp (..), getFullpakModules, getGhcStgAppModules, + getJSONModules, readGhcStgApp) +import Stg.Syntax (Alt, Alt' (..), AltCon, AltCon' (..), AltType, AltType' (..), + Arg, Arg' (..), Binder (..), Binding, Binding' (..), + CCallTarget (..), DC (..), DataCon (..), DataConRep (..), Expr, + Expr' (..), ForeignCall (..), Id (..), IdDetails (..), + Lit (..), LitNumType (..), Module, Module' (..), Name, + PrimRep (..), Rhs, Rhs' (..), StgOp (..), TopBinding' (..), + TyCon, Type (..), UpdateFlag (..)) + +import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory, + makeAbsolute, setCurrentDirectory) +import System.FilePath (FilePath, dropExtension, takeDirectory, takeExtension, + takeFileName, ()) +import System.IO (BufferMode (..), IO, IOMode (..), hClose, hSetBuffering, + openFile, print, putStrLn) +import System.Posix.DynamicLinker (DL, RTLDFlags (..), dlclose, dlopen) + +import Text.Show (Show (..)) + {- Q: what is the operational semantic of StgApp @@ -137,7 +170,7 @@ evalLiteral = \case LitNumber LitNumWord64 n -> pure . WordAtom $ fromIntegral n c@LitChar{} -> pure $ Literal c LitRubbish{} -> pure Rubbish - l -> error $ "unsupported: " ++ show l + -- l -> error $ "unsupported: " ++ show l evalArg :: HasCallStack => Env -> Arg -> M Atom evalArg localEnv = \case @@ -225,8 +258,10 @@ builtinStgEval so a@HeapPtr{} = do BS8.putStrLn . BS8.pack $ unlines argStrs hFlush stdout -} - let StgRhsClosure _ uf params e = getCutShowItem $ hoCloBody - HeapPtr l = a + let (uf, params, e) = case getCutShowItem hoCloBody of + StgRhsClosure _ uf' params' e' -> (uf', params', e') + StgRhsCon _ _ -> error "missed StgRhsClosure" + let HeapPtr l = a extendedEnv = addManyBindersToEnv SO_CloArg params hoCloArgs hoEnv unless (length params == length hoCloArgs) $ do stgErrorM $ "builtinStgEval - Closure - length mismatch: " ++ show (params, hoCloArgs) @@ -265,14 +300,17 @@ builtinStgEval so a@HeapPtr{} = do } evalExpr extendedEnv e SingleEntry -> do - tid <- gets ssCurrentThreadId + _tid <- gets ssCurrentThreadId -- TODO: investigate how does single-entry blackholing cause problem (estgi does not have racy memops as it is mentioned in GHC Note below) -- no backholing, see: GHC Note [Black-holing non-updatable thunks] -- closure will only be entered once, and so need not be updated but may safely be blackholed. --stackPush (Update l) -- FIX??? Q: what will remove the backhole if there is no update? Q: is the value linear? --store l (BlackHole o) -- Q: is this a bug? evalExpr extendedEnv e - _ -> stgErrorM $ "expected evaluable heap object, got: " ++ show a ++ " heap-object: " ++ show o ++ " static-origin: " ++ show so + JumpedTo -> do + -- TODO: i don't know what + evalExpr extendedEnv e + -- _ -> stgErrorM $ "expected evaluable heap object, got: " ++ show a ++ " heap-object: " ++ show o ++ " static-origin: " ++ show so builtinStgEval so a = stgErrorM $ "expected a thunk, got: " ++ show a ++ ", static-origin: " ++ show so builtinStgApply :: HasCallStack => StaticOrigin -> Atom -> [Atom] -> M [Atom] @@ -355,7 +393,7 @@ assertWHNF :: HasCallStack => [Atom] -> AltType -> Binder -> M () assertWHNF [hp@HeapPtr{}] aty res = do o <- readHeap hp case o of - Con _ dc args -> pure () + Con _ _dc _args -> pure () Closure{..} | hoCloMissing == 0 , aty /= MultiValAlt 1 @@ -410,8 +448,7 @@ killAllThreads = do isQuiet <- gets ssIsQuiet unless isQuiet $ when (runnableThreads /= []) $ do reportThreads - error "killing all running threads" - pure () -- TODO + error "killing all running threads" -- TODO evalOnMainThread :: M [Atom] -> M [Atom] evalOnMainThread = evalOnThread True @@ -419,10 +456,10 @@ evalOnMainThread = evalOnThread True evalOnNewThread :: M [Atom] -> M [Atom] evalOnNewThread = evalOnThread False -evalOnThread :: Bool -> M [Atom] -> M [Atom] +evalOnThread :: HasCallStack => Bool -> M [Atom] -> M [Atom] evalOnThread isMainThread setupAction = do -- create main thread - (tid, ts) <- createThread + (tid, _ts) <- createThread scheduleToTheEnd tid switchToThread tid @@ -430,12 +467,13 @@ evalOnThread isMainThread setupAction = do result0 <- setupAction --liftIO $ putStrLn $ "evalOnThread result0 = " ++ show result0 --Debugger.reportState - let loop resultIn = do + let loop :: HasCallStack => [Atom] -> StateT StgState IO [Atom] + loop resultIn = do resultOut <- evalStackMachine resultIn ThreadState{..} <- getThreadState tid - case isThreadLive tsStatus of - True -> loop resultOut -- HINT: the new scheduling is ready - False -> do + if isThreadLive tsStatus then + loop resultOut -- HINT: the new scheduling is ready + else do when isMainThread $ do mylog "[estgi] - main hs thread finished" killAllThreads @@ -458,11 +496,11 @@ evalStackMachine result = do stackPop >>= \case Nothing -> pure result Just stackCont -> do - promptM $ do - putStrLn $ " input result = " ++ show result - putStrLn $ " stack-cont = " ++ showStackCont stackCont + -- promptM $ do + -- putStrLn $ " input result = " ++ show result + -- putStrLn $ " stack-cont = " ++ showStackCont stackCont - doTrace <- gets ssPrimOpTrace + -- _doTrace <- gets ssPrimOpTrace do -- when doTrace $ do resultStr <- mapM debugPrintAtom result traceLog $ showStackCont stackCont ++ " current-result: " ++ show resultStr @@ -471,14 +509,15 @@ evalStackMachine result = do nextResult <- evalStackContinuation result stackCont case stackCont of RunScheduler{} -> pure () - _ -> contextSwitchTimer + _ -> contextSwitchTimer evalStackMachine nextResult peekAtom :: HasCallStack => Atom -> M String peekAtom a = case a of HeapPtr{} -> debugPrintHeapObject <$> readHeap a - _ -> pure $ show a + _ -> pure $ show a +peekAtoms :: [Atom] -> StateT StgState IO [String] peekAtoms = mapM peekAtom evalStackContinuation :: HasCallStack => [Atom] -> StackContinuation -> M [Atom] @@ -486,13 +525,13 @@ evalStackContinuation result = \case Apply args | [fun@HeapPtr{}] <- result -> do - argsS <- peekAtoms args - resultS <- peekAtoms result + _argsS <- peekAtoms args + _resultS <- peekAtoms result --liftIO $ putStrLn $ "evalStackContinuation Apply args: " ++ show args ++ " to " ++ show result --liftIO $ putStrLn $ "evalStackContinuation Apply args: " ++ show argsS ++ " to " ++ show resultS - + out <- builtinStgApply SO_ClosureResult fun args - outS <- peekAtoms out + _outS <- peekAtoms out --liftIO $ putStrLn $ "evalStackContinuation Apply args: " ++ show args ++ " to " ++ show result ++ " output-result: " ++ show out --liftIO $ putStrLn $ "evalStackContinuation Apply args: " ++ show argsS ++ " to " ++ show resultS ++ " output-result: " ++ show outS @@ -513,13 +552,16 @@ evalStackContinuation result = \case CaseOf curClosureAddr curClosure localEnv (Id resultBinder) (CutShow altType) alts -> do modify' $ \s -> s {ssCurrentClosure = Just curClosure, ssCurrentClosureAddr = curClosureAddr} assertWHNF result altType resultBinder - let resultId = (Id resultBinder) + let resultId = Id resultBinder + alt = case getCutShowItem alts of + [] -> undefined + (a : _) -> a + v = case result of + [l] -> l + _ -> error $ "expected a single value: " ++ show result case altType of - AlgAlt tc -> do - let v = case result of - [l] -> l - _ -> error $ "expected a single value: " ++ show result - extendedEnv = addBinderToEnv SO_Scrut resultBinder v localEnv + AlgAlt _tc -> do + let extendedEnv = addBinderToEnv SO_Scrut resultBinder v localEnv con <- readHeapCon v matchFirstCon resultId extendedEnv con $ getCutShowItem alts @@ -532,10 +574,10 @@ evalStackContinuation result = \case MultiValAlt n -> do -- unboxed tuple -- NOTE: result binder is not assigned - let [Alt{..}] = getCutShowItem alts + let Alt{..} = alt when (n /= length altBinders) $ do stgErrorM $ "evalStackContinuation - MultiValAlt n broken assumption 2: " ++ show (n, altBinders, result) - let extendedEnv = if n == 1 && altBinders == [] + let extendedEnv = if n == 1 && null altBinders then addManyBindersToEnv SO_Scrut [resultBinder] result localEnv else addManyBindersToEnv SO_Scrut altBinders result localEnv --unless (length altBinders == length result) $ do @@ -545,10 +587,8 @@ evalStackContinuation result = \case evalExpr extendedEnv altRHS PolyAlt -> do - let [Alt{..}] = getCutShowItem alts - [v] = result - extendedEnv = addBinderToEnv SO_Scrut resultBinder v $ -- HINT: bind the result - localEnv + let Alt{..} = alt + extendedEnv = addBinderToEnv SO_Scrut resultBinder v localEnv -- HINT: bind the result --addManyBindersToEnv SO_AltArg altBinders result localEnv -- HINT: bind alt params {- unless (length altBinders == length result) $ do @@ -557,29 +597,29 @@ evalStackContinuation result = \case setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId resultBinder) 0 evalExpr extendedEnv altRHS - s@(RestoreExMask oldMask blockAsyncEx isInterruptible) -> do + (RestoreExMask _oldMask blockAsyncEx isInterruptible) -> do tid <- gets ssCurrentThreadId ts <- getCurrentThreadState updateThreadState tid $ ts {tsBlockExceptions = blockAsyncEx, tsInterruptible = isInterruptible} case tsBlockedExceptions ts of (thowingTid, exception) : waitingTids - | blockAsyncEx == False + | not blockAsyncEx -> do -- try wake up thread throwingTS <- getThreadState thowingTid when (tsStatus throwingTS == ThreadBlocked (BlockedOnThrowAsyncEx tid)) $ do updateThreadState thowingTid throwingTS {tsStatus = ThreadRunning} -- raise exception - ts <- getCurrentThreadState - updateThreadState tid ts {tsBlockedExceptions = waitingTids} + ts' <- getCurrentThreadState + updateThreadState tid ts' {tsBlockedExceptions = waitingTids} PrimConcurrency.raiseAsyncEx result tid exception _ -> pure () pure result - Catch h b i -> do + Catch _h b i -> do -- TODO: is anything to do?? -- assert if current mask is the same as the one in stack frame - ts@ThreadState{..} <- getCurrentThreadState + ThreadState{..} <- getCurrentThreadState when (tsBlockExceptions /= b || tsInterruptible /= i) $ do error $ "Catch frame assertion failure - ex mask mismatch, expected: " ++ show (b, i) ++ " got: " ++ show (tsBlockExceptions, tsInterruptible) pure result @@ -613,7 +653,7 @@ evalStackContinuation result = \case x -> error $ "unsupported continuation: " ++ show x ++ ", result: " ++ show result -evalDebugFrame :: [Atom] -> DebugFrame -> M [Atom] +evalDebugFrame :: HasCallStack => [Atom] -> DebugFrame -> M [Atom] evalDebugFrame result = \case RestoreProgramPoint currentClosure progPoint -> do modify' $ \s -> s {ssCurrentClosure = currentClosure} @@ -624,7 +664,7 @@ evalDebugFrame result = \case traceLog "full-trace-off" pure result - x -> error $ "unsupported debug-frame: " ++ show x ++ ", result: " ++ show result + -- x -> error $ "unsupported debug-frame: " ++ show x ++ ", result: " ++ show result evalExpr :: HasCallStack => Env -> Expr -> M [Atom] evalExpr localEnv = \case @@ -713,7 +753,7 @@ evalExpr localEnv = \case Debugger.checkRegion op markPrimOp op args <- mapM (evalArg localEnv) l - tid <- gets ssCurrentThreadId + _tid <- gets ssCurrentThreadId result <- evalPrimOp op args t tc doTrace <- gets ssPrimOpTrace when doTrace $ traceLog $ show (op, args) @@ -747,36 +787,35 @@ evalExpr localEnv = \case putStrLn " args:" forM_ l $ \a -> do putStrLn $ " " ++ show a - stgErrorM $ "illegal createAdjustor call" + stgErrorM "illegal createAdjustor call" _ -> mapM (evalArg localEnv) l --mylog $ show ("executing", foreignCall, args) - result <- evalFCallOp evalOnNewThread foreignCall args t tc + evalFCallOp evalOnNewThread foreignCall args t tc --mylog $ show (foreignCall, args, result) - pure result StgOpApp (StgPrimCallOp primCall) l t tc -> do markPrimCall primCall args <- mapM (evalArg localEnv) l - result <- evalPrimCallOp primCall args t tc + evalPrimCallOp primCall args t tc --liftIO $ print (primCall, args, result) - pure result - StgOpApp op _args t _tc -> stgErrorM $ "unsupported StgOp: " ++ show op ++ " :: " ++ show t + -- StgOpApp op _args t _tc -> stgErrorM $ "unsupported StgOp: " ++ show op ++ " :: " ++ show t matchFirstLit :: HasCallStack => Id -> Env -> Atom -> [Alt] -> M [Atom] -matchFirstLit resultId localEnv a [Alt AltDefault _ rhs] = do +matchFirstLit resultId localEnv _a [Alt AltDefault _ rhs] = do setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId $ unId resultId) 0 evalExpr localEnv rhs matchFirstLit resultId localEnv atom alts | indexedAlts <- zip [0..] alts , indexedAltsWithDefault <- case indexedAlts of d@(_, Alt AltDefault _ _) : xs -> xs ++ [d] - xs -> xs - = case head $ [a | a@(_idx, Alt{..}) <- indexedAltsWithDefault, matchLit atom altCon] ++ (error $ "no lit match" ++ show (resultId, atom, map altCon alts)) of - (idx, Alt{..}) -> do - setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId $ unId resultId) idx - evalExpr localEnv altRHS + xs -> xs + = case [a | a@(_idx, Alt{..}) <- indexedAltsWithDefault, matchLit atom altCon] of + [] -> error $ "no lit match" ++ show (resultId, atom, fmap altCon alts) + ((idx, Alt{..}) : _) -> do + setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId $ unId resultId) idx + evalExpr localEnv altRHS matchLit :: HasCallStack => Atom -> AltCon -> Bool matchLit a = \case @@ -786,40 +825,46 @@ matchLit a = \case convertAltLit :: Lit -> Atom convertAltLit lit = case lit of - LitFloat f -> FloatAtom $ realToFrac f - LitDouble d -> DoubleAtom $ realToFrac d - LitNullAddr -> PtrAtom RawPtr nullPtr - LitNumber LitNumInt n -> IntAtom $ fromIntegral n - LitNumber LitNumInt8 n -> IntAtom $ fromIntegral n - LitNumber LitNumInt16 n -> IntAtom $ fromIntegral n - LitNumber LitNumInt32 n -> IntAtom $ fromIntegral n - LitNumber LitNumInt64 n -> IntAtom $ fromIntegral n - LitNumber LitNumWord n -> WordAtom $ fromIntegral n - LitNumber LitNumWord8 n -> WordAtom $ fromIntegral n - LitNumber LitNumWord16 n -> WordAtom $ fromIntegral n - LitNumber LitNumWord32 n -> WordAtom $ fromIntegral n - LitNumber LitNumWord64 n -> WordAtom $ fromIntegral n - LitLabel{} -> error $ "invalid alt pattern: " ++ show lit - LitString{} -> error $ "invalid alt pattern: " ++ show lit - c@LitChar{} -> Literal c - l -> error $ "unsupported: " ++ show l + LitFloat f -> FloatAtom $ realToFrac f + LitDouble d -> DoubleAtom $ realToFrac d + LitNullAddr -> PtrAtom RawPtr nullPtr + LitNumber LitNumInt n -> IntAtom $ fromIntegral n + LitNumber LitNumInt8 n -> IntAtom $ fromIntegral n + LitNumber LitNumInt16 n -> IntAtom $ fromIntegral n + LitNumber LitNumInt32 n -> IntAtom $ fromIntegral n + LitNumber LitNumInt64 n -> IntAtom $ fromIntegral n + LitNumber LitNumWord n -> WordAtom $ fromIntegral n + LitNumber LitNumWord8 n -> WordAtom $ fromIntegral n + LitNumber LitNumWord16 n -> WordAtom $ fromIntegral n + LitNumber LitNumWord32 n -> WordAtom $ fromIntegral n + LitNumber LitNumWord64 n -> WordAtom $ fromIntegral n + LitLabel{} -> error $ "invalid alt pattern: " ++ show lit + LitString{} -> error $ "invalid alt pattern: " ++ show lit + c@LitChar{} -> Literal c + l -> error $ "unsupported: " ++ show l matchFirstCon :: HasCallStack => Id -> Env -> HeapObject -> [Alt] -> M [Atom] -matchFirstCon resultId localEnv (Con _ (DC dc) args) alts +matchFirstCon resultId localEnv heap alts | indexedAlts <- zip [0..] alts , indexedAltsWithDefault <- case indexedAlts of d@(_, Alt AltDefault _ _) : xs -> xs ++ [d] - xs -> xs - = case [a | a@(_idx, Alt{..}) <- indexedAltsWithDefault, matchCon dc altCon] of - [] -> stgErrorM $ "no matching alts for: " ++ show resultId - (idx, Alt{..}) : _ -> do - let extendedEnv = case altCon of - AltDataCon{} -> addManyBindersToEnv SO_AltArg altBinders args localEnv - _ -> localEnv - --unless (length altBinders == length args) $ do - -- stgErrorM $ "matchFirstCon length mismatch: " ++ show (DC dc, altBinders, args, resultId) - setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId $ unId resultId) idx - evalExpr extendedEnv altRHS + xs -> xs + = case heap of + (Con _ (DC dc) args) -> do + case [a | a@(_idx, Alt{..}) <- indexedAltsWithDefault, matchCon dc altCon] of + [] -> stgErrorM $ "no matching alts for: " ++ show resultId + (idx, Alt{..}) : _ -> do + let extendedEnv = case altCon of + AltDataCon{} -> addManyBindersToEnv SO_AltArg altBinders args localEnv + _ -> localEnv + --unless (length altBinders == length args) $ do + -- stgErrorM $ "matchFirstCon length mismatch: " ++ show (DC dc, altBinders, args, resultId) + setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId $ unId resultId) idx + evalExpr extendedEnv altRHS + Closure {} -> error "unsupported" + BlackHole {} -> error "unsupported" + ApStack _ _ -> error "unsupported" + RaiseException _ -> error "unsupported" matchCon :: HasCallStack => DataCon -> AltCon -> Bool matchCon a = \case @@ -839,7 +884,7 @@ declareBinding isLetNoEscape localEnv = \case StgRec l -> do (ls, newEnvItems) <- fmap unzip . forM l $ \(b, _) -> do addr <- freshHeapAddress - pure (addr, (b, (HeapPtr addr))) + pure (addr, (b, HeapPtr addr)) let extendedEnv = addZippedBindersToEnv SO_Let newEnvItems localEnv forM_ (zip ls l) $ \(addr, (b, rhs)) -> do storeRhs isLetNoEscape extendedEnv b addr rhs @@ -854,7 +899,7 @@ storeRhs isLetNoEscape localEnv i addr = \case store addr (Con isLetNoEscape (DC dc) args) cl@(StgRhsClosure freeVars _ paramNames _) -> do - let liveSet = Set.fromList $ map Id freeVars + let liveSet = Set.fromList $ fmap Id freeVars prunedEnv = Map.restrictKeys localEnv liveSet -- HINT: do pruning to keep only the live/later referred variables store addr (Closure isLetNoEscape (Id i) (CutShow cl) prunedEnv [] (length paramNames)) @@ -862,27 +907,30 @@ storeRhs isLetNoEscape localEnv i addr = \case declareTopBindings :: HasCallStack => [Module] -> M () declareTopBindings mods = do - let (strings, closures) = partition isStringLit $ (concatMap moduleTopBindings) mods + let (strings, closures) = partition isStringLit $ concatMap moduleTopBindings mods isStringLit = \case StgTopStringLit{} -> True _ -> False -- bind string lits - stringEnv <- forM strings $ \(StgTopStringLit b str) -> do - strPtr <- getCStringConstantPtrAtom str - pure (Id b, (SO_TopLevel, strPtr)) + stringEnv <- forM strings $ \case + (StgTopStringLit b str) -> do + strPtr <- getCStringConstantPtrAtom str + pure (Id b, (SO_TopLevel, strPtr)) + StgTopLifted _ -> error "unsupported" -- bind closures let bindings = concatMap getBindings closures getBindings = \case StgTopLifted (StgNonRec i rhs) -> [(i, rhs)] StgTopLifted (StgRec l) -> l + StgTopStringLit _ _ -> error "unsupported" (closureEnv, rhsList) <- fmap unzip . forM bindings $ \(b, rhs) -> do addr <- freshHeapAddress pure ((Id b, (SO_TopLevel, HeapPtr addr)), (b, addr, rhs)) -- set the top level binder env - modify' $ \s@StgState{..} -> s {ssStaticGlobalEnv = Map.fromList $ stringEnv ++ closureEnv} + modify' $ \s -> s {ssStaticGlobalEnv = Map.fromList $ stringEnv ++ closureEnv} -- HINT: top level closures does not capture local variables forM_ rhsList $ \(b, addr, rhs) -> storeRhs False mempty b addr rhs @@ -895,7 +943,7 @@ usesMultiThreadedRts fullpak_name = do GhcStgApp{..} <- Y.decodeThrow bs pure $ "WayThreaded" `elem` appWays ".json" -> error "TODO: read rts concurrency mode from json" - ext | isSuffixOf "_ghc_stgapp" ext -> do + ext | "_ghc_stgapp" `isSuffixOf` ext -> do GhcStgApp{..} <- readGhcStgApp fullpak_name pure $ "WayThreaded" `elem` appWays _ -> error "unknown input file format" @@ -904,16 +952,16 @@ loadAndRunProgram :: HasCallStack => Bool -> Bool -> String -> [String] -> Debug loadAndRunProgram isQuiet switchCWD fullpak_name progArgs dbgChan dbgState tracing debugSettings = do mods0 <- case takeExtension fullpak_name of - ".fullpak" -> getFullpakModules fullpak_name - ".json" -> getJSONModules fullpak_name - ext | isSuffixOf "_ghc_stgapp" ext -> getGhcStgAppModules fullpak_name - _ -> error "unknown input file format" + ".fullpak" -> getFullpakModules fullpak_name + ".json" -> getJSONModules fullpak_name + ext | "_ghc_stgapp" `isSuffixOf` ext -> getGhcStgAppModules fullpak_name + _ -> error "unknown input file format" runProgram isQuiet switchCWD fullpak_name mods0 progArgs dbgChan dbgState tracing debugSettings runProgram :: HasCallStack => Bool -> Bool -> String -> [Module] -> [String] -> DebuggerChan -> DebugState -> Bool -> DebugSettings -> IO () runProgram isQuiet switchCWD progFilePath mods0 progArgs dbgChan dbgState tracing debugSettings = do - let mods = map annotateWithLiveVariables $ extStgRtsSupportModule : mods0 -- NOTE: add RTS support module - progName = dropExtension progFilePath + let mods = fmap annotateWithLiveVariables $ extStgRtsSupportModule : mods0 -- NOTE: add RTS support module + progName = dropExtension progFilePath usesMultiThreadedRts progFilePath >>= \case True -> error "TODO: implement concurrent FFI semantics" @@ -921,25 +969,26 @@ runProgram isQuiet switchCWD progFilePath mods0 progArgs dbgChan dbgState tracin currentDir <- liftIO getCurrentDirectory stgappDir <- makeAbsolute $ takeDirectory progFilePath - --putStrLn $ "progName: " ++ show progName ++ " progArgs: " ++ show progArgs - let run = do + + let run ::HasCallStack => StateT StgState IO () + run = do when switchCWD $ liftIO $ setCurrentDirectory stgappDir declareTopBindings mods buildCWrapperHsTypeMap mods initRtsSupport progName progArgs mods env <- gets ssStaticGlobalEnv let rootMain = unId $ case [i | i <- Map.keys env, show i == "main_:Main.main"] of - [mainId] -> mainId - [] -> error "main_:Main.main not found" - _ -> error "multiple main_:Main.main have found" + [mainId] -> mainId + [] -> error "main_:Main.main not found" + _ -> error "multiple main_:Main.main have found" limit <- gets ssNextHeapAddr - modify' $ \s@StgState{..} -> s {ssDynamicHeapStart = limit} - modify' $ \s@StgState{..} -> s {ssStgErrorAction = Printable $ Debugger.processCommandsUntilExit} + modify' $ \s -> s {ssDynamicHeapStart = limit} + modify' $ \s -> s {ssStgErrorAction = Printable Debugger.processCommandsUntilExit} -- TODO: check how it is done in the native RTS: call hs_main mainAtom <- lookupEnv mempty rootMain - evalOnMainThread $ do + _ <- evalOnMainThread $ do stackPush $ Apply [Void] pure [mainAtom] @@ -960,9 +1009,10 @@ runProgram isQuiet switchCWD progFilePath mods0 progArgs dbgChan dbgState tracin when (dbgState == DbgStepByStep) $ do Debugger.processCommandsUntilExit - tracingState <- case tracing of - False -> pure NoTracing - True -> do + tracingState <- + if tracing then + pure NoTracing + else do let tracePath = ".extstg-trace" takeFileName progName createDirectoryIfMissing True tracePath fd <- openFile (progName ++ ".whole-program-path.tsv") WriteMode @@ -983,9 +1033,9 @@ runProgram isQuiet switchCWD progFilePath mods0 progArgs dbgChan dbgState tracin hClose wpp hClose h _ -> pure () - flip catch (\e -> do {freeResources; throw (e :: SomeException)}) $ do + handle (\e -> do {freeResources; throw (e :: SomeException)}) $ do now <- getCurrentTime - s@StgState{..} <- execStateT run (emptyStgState now isQuiet stateStore dl dbgChan dbgState tracingState debugSettings gcIn gcOut) + StgState{..} <- execStateT run (emptyStgState now isQuiet stateStore dl dbgChan dbgState tracingState debugSettings gcIn gcOut) when switchCWD $ setCurrentDirectory currentDir freeResources @@ -1027,7 +1077,7 @@ loadCbitsSO isQuiet progFilePath = do flushStdHandles :: M () flushStdHandles = do Rts{..} <- gets ssRtsSupport - evalOnMainThread $ do + void $ evalOnMainThread $ do stackPush $ Apply [] -- HINT: force IO monad result to WHNF stackPush $ Apply [Void] pure [rtsTopHandlerFlushStdHandles] @@ -1044,7 +1094,6 @@ flushStdHandles = do [] -> pure resultLazy [valueThunk] -> builtinStgEval valueThunk -- pure resultLazy -- builtinStackMachineApply valueThunk [] -} - pure () @@ -1184,6 +1233,6 @@ evalPrimOp = PrimUnsafe.evalPrimOp $ PrimMiscEtc.evalPrimOp $ PrimObjectLifetime.evalPrimOp $ - PrimInfoTableOrigin.evalPrimOp $ + PrimInfoTableOrigin.evalPrimOp unsupported where unsupported op args _t _tc = stgErrorM $ "unsupported StgPrimOp: " ++ show op ++ " args: " ++ show args diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Base.hs b/external-stg-interpreter/lib/Stg/Interpreter/Base.hs index 49af317..4b36dc5 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Base.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Base.hs @@ -1,58 +1,108 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Stg.Interpreter.Base where -import Data.Word -import Foreign.Ptr -import Foreign.C.Types -import Control.Monad.State.Strict -import Data.List (foldl') -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as StrictMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Lazy as BL -import Data.Vector (Vector) -import qualified Data.Primitive.ByteArray as BA -import Control.Monad.Primitive -import System.Posix.DynamicLinker -import Control.Concurrent.MVar -import Control.Concurrent.Chan.Unagi.Bounded -import Foreign.ForeignPtr.Unsafe -import Data.Time.Clock -import System.IO -import Text.Pretty.Simple (pShowNoColor, pShow) -import qualified Data.Text.Lazy.IO as Text - -import GHC.Stack -import Text.Printf -import Debug.Trace -import Stg.Syntax -import Stg.IRLocation +import Control.Applicative (Applicative (..), (<$>)) +import Control.Concurrent.Chan.Unagi.Bounded (InChan, OutChan) +import Control.Concurrent.MVar (MVar, putMVar, takeMVar) +import Control.Monad (Functor (..), Monad (..), forM, forM_, mapM_, unless, void, + when) +import Control.Monad.Primitive (RealWorld) +import Control.Monad.State.Strict (MonadIO (..), MonadState (..), StateT, gets, modify') + +import Data.Bool (Bool (..), otherwise) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Internal as BS +import Data.Char (Char) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List (and, any, drop, foldl', length, (++)) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as StrictMap +import Data.Maybe (Maybe (..), maybe) +import Data.Monoid (Monoid (..)) +import Data.Ord (Ord (..), Ordering (..)) +import qualified Data.Primitive.ByteArray as BA +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (String) +import qualified Data.Text.Lazy.IO as Text +import Data.Time.Clock (UTCTime) +import Data.Tuple (snd) +import Data.Vector (Vector) +import Data.Word (Word, Word8) + +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Ptr (IntPtr (..), Ptr, plusPtr, ptrToIntPtr) + +import GHC.Err (error, undefined) +import GHC.Float (Double, Float) +import GHC.Num (Num (..)) +import GHC.Stack (HasCallStack, callStack, prettyCallStack) + +import Prelude (Enum (..)) + +import Stg.IRLocation (StgPoint) +import Stg.Syntax (Alt, AltType, Binder (..), DC (..), DataCon (..), ForeignCall, + Id (..), LabelSpec, Lit (..), Name, PrimCall, Rhs, TyCon, Type) + +import System.IO (Handle, IO, hPutStrLn, print, putStrLn) +import System.Posix.DynamicLinker (DL) + +import Text.Pretty.Simple (pShowNoColor) +import Text.Read (Read) +import Text.Show (Show (..)) + +pattern CharV :: Char -> Atom +pattern CharV c = Literal (LitChar c) +pattern IntV :: Int -> Atom +pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) +pattern Int8V :: Int -> Atom +pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) +pattern Int16V :: Int -> Atom +pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) +pattern Int32V :: Int -> Atom +pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) +pattern Int64V :: Int -> Atom +pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) +pattern WordV :: Word -> Atom +pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) +pattern Word8V :: Word -> Atom +pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) +pattern Word16V :: Word -> Atom +pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) +pattern Word32V :: Word -> Atom +pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +pattern Word64V :: Word -> Atom +pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) +pattern FloatV :: Float -> Atom +pattern FloatV f = FloatAtom f +pattern DoubleV :: Double -> Atom +pattern DoubleV d = DoubleAtom d type StgRhsClosure = Rhs -- NOTE: must be StgRhsClosure only! data ArrIdx = MutArrIdx !Int | ArrIdx !Int - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data SmallArrIdx = SmallMutArrIdx !Int | SmallArrIdx !Int - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data ArrayArrIdx = ArrayMutArrIdx !Int | ArrayArrIdx !Int - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data ByteArrayIdx = ByteArrayIdx @@ -60,7 +110,7 @@ data ByteArrayIdx , baPinned :: !Bool , baAlignment :: !Int } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data ByteArrayDescriptor = ByteArrayDescriptor @@ -70,12 +120,15 @@ data ByteArrayDescriptor , baaAlignment :: !Int } instance Show ByteArrayDescriptor where + show :: ByteArrayDescriptor -> String show _ = "ByteArrayDescriptor (TODO)" instance Eq ByteArrayDescriptor where + (==) :: ByteArrayDescriptor -> ByteArrayDescriptor -> Bool _ == _ = True -- TODO instance Ord ByteArrayDescriptor where + compare :: ByteArrayDescriptor -> ByteArrayDescriptor -> Ordering _ `compare` _ = EQ -- TODO data PtrOrigin @@ -86,30 +139,30 @@ data PtrOrigin | CostCentreStackPtr -- GHC Cmm STG machine's cost centre stack | StablePtr !Int -- stable pointer must have AddrRep | LabelPtr !Name !LabelSpec -- foreign symbol/label name + label sepcification (i.e. data or function) - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data WeakPtrDescriptor = WeakPtrDescriptor - { wpdKey :: Atom - , wpdValue :: Maybe Atom -- live or dead - , wpdFinalizer :: Maybe Atom -- closure - , wpdCFinalizers :: [(Atom, Maybe Atom, Atom)] -- fun, env ptr, data ptr + { wpdKey :: Atom + , wpdValue :: Maybe Atom -- live or dead + , wpdFinalizer :: Maybe Atom -- closure + , wpdCFinalizers :: [(Atom, Maybe Atom, Atom)] -- fun, env ptr, data ptr } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data MVarDescriptor = MVarDescriptor - { mvdValue :: Maybe Atom - , mvdQueue :: [Int] -- thread id, blocking in this mvar ; this is required only for the fairness ; INVARIANT: BlockedOnReads are present at the beginning of the queue + { mvdValue :: Maybe Atom + , mvdQueue :: [Int] -- thread id, blocking in this mvar ; this is required only for the fairness ; INVARIANT: BlockedOnReads are present at the beginning of the queue } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data TVarDescriptor = TVarDescriptor - { tvdValue :: Atom - , tvdQueue :: IntSet -- thread id, STM wake up queue + { tvdValue :: Atom + , tvdQueue :: IntSet -- thread id, STM wake up queue } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) -- TODO: detect coercions during the evaluation data Atom -- Q: should atom fit into a cpu register? A: yes @@ -138,29 +191,30 @@ data Atom -- Q: should atom fit into a cpu register? A: yes | LiftedUndefined | Rubbish | Unbinded !Id -- program point that created this value (used for debug purposes) - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) type ReturnValue = [Atom] newtype CutShow a = CutShow {getCutShowItem :: a} - deriving (Eq, Ord) + deriving stock (Eq, Ord) instance Show (CutShow a) where + show :: CutShow a -> String show _ = "" data HeapObject = Con - { hoIsLNE :: Bool - , hoCon :: DC - , hoConArgs :: [Atom] + { hoIsLNE :: Bool + , hoCon :: DC + , hoConArgs :: [Atom] } | Closure - { hoIsLNE :: Bool - , hoName :: Id - , hoCloBody :: CutShow StgRhsClosure - , hoEnv :: Env -- local environment ; with live variables only, everything else is pruned - , hoCloArgs :: [Atom] - , hoCloMissing :: Int -- HINT: this is a Thunk if 0 arg is missing ; if all is missing then Fun ; Pap is some arg is provided + { hoIsLNE :: Bool + , hoName :: Id + , hoCloBody :: CutShow StgRhsClosure + , hoEnv :: Env -- local environment ; with live variables only, everything else is pruned + , hoCloArgs :: [Atom] + , hoCloMissing :: Int -- HINT: this is a Thunk if 0 arg is missing ; if all is missing then Fun ; Pap is some arg is provided } | BlackHole -- NOTE: each blackhole has exactly one corresponding thread and one update frame { hoBHOwnerThreadId :: Int -- owner thread id @@ -168,11 +222,11 @@ data HeapObject , hoBHWaitQueue :: [Int] -- blocking queue of thread ids } | ApStack -- HINT: needed for the async exceptions - { hoResult :: [Atom] - , hoStack :: [StackContinuation] + { hoResult :: [Atom] + , hoStack :: [StackContinuation] } | RaiseException Atom - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data StackContinuation -- basic block related @@ -200,12 +254,12 @@ data StackContinuation | KeepAlive !Atom -- ext stg interpreter debug related | DebugFrame !DebugFrame -- for debug purposes, it does not required for STG evaluation - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data DebugFrame = RestoreProgramPoint !(Maybe Id) !ProgramPoint | DisablePrimOpTrace - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data ScheduleReason = SR_ThreadFinished @@ -213,7 +267,7 @@ data ScheduleReason | SR_ThreadFinishedFFICallback | SR_ThreadBlocked | SR_ThreadYield - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) {- Q: do we want homogeneous or heterogeneous Heap ; e.g. single intmap with mixed things or multiple intmaps/vector with multiple address spaces @@ -221,35 +275,39 @@ data ScheduleReason newtype Printable a = Printable {unPrintable :: a} instance Show (Printable a) where + show :: Printable a -> String show _ = "Printable" -newtype PrintableMVar a = PrintableMVar {unPrintableMVar :: MVar a} deriving Eq +newtype PrintableMVar a = PrintableMVar {unPrintableMVar :: MVar a} + deriving stock Eq instance Show (PrintableMVar a) where + show :: PrintableMVar a -> String show _ = "MVar" data DebuggerChan = DebuggerChan - { dbgSyncRequest :: MVar DebugCommand - , dbgSyncResponse :: MVar DebugOutput - , dbgAsyncEventIn :: InChan DebugEvent - , dbgAsyncEventOut :: OutChan DebugEvent + { dbgSyncRequest :: MVar DebugCommand + , dbgSyncResponse :: MVar DebugOutput + , dbgAsyncEventIn :: InChan DebugEvent + , dbgAsyncEventOut :: OutChan DebugEvent } - deriving Eq + deriving stock Eq instance Show DebuggerChan where + show :: DebuggerChan -> String show _ = "DebuggerChan" data DebugEvent = DbgEventHitBreakpoint !Breakpoint | DbgEventStopped - deriving (Show) + deriving stock (Show) data Breakpoint = BkpStgPoint StgPoint | BkpPrimOp Name | BkpFFISymbol Name | BkpCustom Name - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) data DebugCommand = CmdListClosures @@ -262,7 +320,7 @@ data DebugCommand | CmdPeekHeap Addr | CmdStop | CmdInternal String -- HINT: non-reified commands for quick experimentation - deriving (Show) + deriving stock (Show) data DebugOutput = DbgOutCurrentClosure !(Maybe Id) !Addr !Env @@ -274,27 +332,27 @@ data DebugOutput | DbgOutString !String | DbgOutByteString !ByteString | DbgOut - deriving (Show) + deriving stock (Show) data DebugState = DbgRunProgram | DbgStepByStep - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data TracingState = NoTracing | DoTracing - { thOriginDB :: Handle - , thWholeProgramPath :: Handle + { thOriginDB :: Handle + , thWholeProgramPath :: Handle } - deriving (Show) + deriving stock (Show) data CallGraph = CallGraph { cgInterClosureCallGraph :: !(StrictMap.Map (StaticOrigin, ProgramPoint, ProgramPoint) Int) , cgIntraClosureCallGraph :: !(StrictMap.Map (ProgramPoint, StaticOrigin, ProgramPoint) Int) } - deriving (Show) + deriving stock (Show) joinCallGraph :: CallGraph -> CallGraph -> CallGraph joinCallGraph (CallGraph a1 b1) (CallGraph a2 b2) = CallGraph (StrictMap.unionWith (+) a1 a2) (StrictMap.unionWith (+) b1 b2) @@ -311,7 +369,7 @@ type Env = Map Id (StaticOrigin, Atom) -- NOTE: must contain only the defin type Stack = [StackContinuation] envToAtoms :: Env -> [Atom] -envToAtoms = map snd . Map.elems +envToAtoms = fmap snd . Map.elems data StaticOrigin = SO_CloArg @@ -321,13 +379,13 @@ data StaticOrigin | SO_TopLevel | SO_Builtin | SO_ClosureResult - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) -data DebugSettings +newtype DebugSettings = DebugSettings { dsKeepGCFacts :: Bool } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) defaultDebugSettings :: DebugSettings defaultDebugSettings @@ -336,54 +394,54 @@ defaultDebugSettings } newtype GCSymbol = GCSymbol {unGCSymbol :: ByteString} - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) data StgState = StgState - { ssHeap :: !Heap - , ssStaticGlobalEnv :: !Env -- NOTE: top level bindings only! - , ssDynamicHeapStart :: !Int + { ssHeap :: !Heap + , ssStaticGlobalEnv :: !Env -- NOTE: top level bindings only! + , ssDynamicHeapStart :: !Int -- GC - , ssLastGCTime :: !UTCTime - , ssLastGCAddr :: !Int - , ssGCInput :: PrintableMVar ([Atom], StgState) - , ssGCOutput :: PrintableMVar RefSet - , ssGCIsRunning :: Bool - , ssGCCounter :: Int - , ssRequestMajorGC :: Bool - , ssCAFSet :: IntSet + , ssLastGCTime :: !UTCTime + , ssLastGCAddr :: !Int + , ssGCInput :: PrintableMVar ([Atom], StgState) + , ssGCOutput :: PrintableMVar RefSet + , ssGCIsRunning :: Bool + , ssGCCounter :: Int + , ssRequestMajorGC :: Bool + , ssCAFSet :: IntSet -- let-no-escape support - , ssTotalLNECount :: !Int + , ssTotalLNECount :: !Int -- string constants ; models the program memory's static constant region -- HINT: the value is a PtrAtom that points to the key BS's content - , ssCStringConstants :: Map ByteString Atom + , ssCStringConstants :: Map ByteString Atom -- threading - , ssThreads :: IntMap ThreadState + , ssThreads :: IntMap ThreadState -- thread scheduler related - , ssCurrentThreadId :: Int - , ssScheduledThreadIds :: [Int] -- HINT: one round - , ssThreadStepBudget :: !Int + , ssCurrentThreadId :: Int + , ssScheduledThreadIds :: [Int] -- HINT: one round + , ssThreadStepBudget :: !Int -- primop related - , ssStableNameMap :: Map Atom Int - , ssWeakPointers :: IntMap WeakPtrDescriptor - , ssStablePointers :: IntMap Atom - , ssMutableByteArrays :: IntMap ByteArrayDescriptor - , ssMVars :: IntMap MVarDescriptor - , ssTVars :: IntMap TVarDescriptor - , ssMutVars :: IntMap Atom - , ssArrays :: IntMap (Vector Atom) - , ssMutableArrays :: IntMap (Vector Atom) - , ssSmallArrays :: IntMap (Vector Atom) - , ssSmallMutableArrays :: IntMap (Vector Atom) - , ssArrayArrays :: IntMap (Vector Atom) - , ssMutableArrayArrays :: IntMap (Vector Atom) + , ssStableNameMap :: Map Atom Int + , ssWeakPointers :: IntMap WeakPtrDescriptor + , ssStablePointers :: IntMap Atom + , ssMutableByteArrays :: IntMap ByteArrayDescriptor + , ssMVars :: IntMap MVarDescriptor + , ssTVars :: IntMap TVarDescriptor + , ssMutVars :: IntMap Atom + , ssArrays :: IntMap (Vector Atom) + , ssMutableArrays :: IntMap (Vector Atom) + , ssSmallArrays :: IntMap (Vector Atom) + , ssSmallMutableArrays :: IntMap (Vector Atom) + , ssArrayArrays :: IntMap (Vector Atom) + , ssMutableArrayArrays :: IntMap (Vector Atom) , ssNextThreadId :: !Int , ssNextHeapAddr :: {-# UNPACK #-} !Int @@ -402,71 +460,71 @@ data StgState , ssNextMutableArrayArray :: !Int -- FFI related - , ssCBitsMap :: DL - , ssStateStore :: PrintableMVar StgState + , ssCBitsMap :: DL + , ssStateStore :: PrintableMVar StgState -- FFI + createAdjustor - , ssCWrapperHsTypeMap :: !(Map Name (Bool, Name, [Name])) + , ssCWrapperHsTypeMap :: !(Map Name (Bool, Name, [Name])) -- RTS related - , ssRtsSupport :: Rts + , ssRtsSupport :: Rts -- debug - , ssIsQuiet :: Bool - , ssLocalEnv :: [Atom] - , ssCurrentClosureEnv :: Env - , ssCurrentClosure :: Maybe Id - , ssCurrentClosureAddr :: Int - , ssExecutedClosures :: !(Set Int) - , ssExecutedClosureIds :: !(Set Id) - , ssExecutedPrimOps :: !(Set Name) - , ssExecutedFFI :: !(Set ForeignCall) - , ssExecutedPrimCalls :: !(Set PrimCall) - , ssClosureCallCounter :: !Int - , ssPrimOpTrace :: !Bool + , ssIsQuiet :: Bool + , ssLocalEnv :: [Atom] + , ssCurrentClosureEnv :: Env + , ssCurrentClosure :: Maybe Id + , ssCurrentClosureAddr :: Int + , ssExecutedClosures :: !(Set Int) + , ssExecutedClosureIds :: !(Set Id) + , ssExecutedPrimOps :: !(Set Name) + , ssExecutedFFI :: !(Set ForeignCall) + , ssExecutedPrimCalls :: !(Set PrimCall) + , ssClosureCallCounter :: !Int + , ssPrimOpTrace :: !Bool -- call graph - , ssCallGraph :: !CallGraph - , ssCurrentProgramPoint :: !ProgramPoint + , ssCallGraph :: !CallGraph + , ssCurrentProgramPoint :: !ProgramPoint -- debugger API - , ssDebuggerChan :: DebuggerChan + , ssDebuggerChan :: DebuggerChan - , ssEvaluatedClosures :: !(Set Name) - , ssBreakpoints :: !(Map Breakpoint Int) - , ssStepCounter :: !Int - , ssDebugFuel :: !(Maybe Int) - , ssDebugState :: DebugState - , ssStgErrorAction :: Printable (M ()) + , ssEvaluatedClosures :: !(Set Name) + , ssBreakpoints :: !(Map Breakpoint Int) + , ssStepCounter :: !Int + , ssDebugFuel :: !(Maybe Int) + , ssDebugState :: DebugState + , ssStgErrorAction :: Printable (M ()) -- region tracker - , ssMarkers :: !(Map Name (Set Region)) - , ssRegionStack :: !(Map (Int, Region) [(Int, AddressState, CallGraph)]) -- HINT: key = threadId + region ; value = index + start + call-graph - , ssRegionInstances :: !(Map Region (IntMap (AddressState, AddressState))) -- region => instance-index => start end - , ssRegionCounter :: !(Map Region Int) + , ssMarkers :: !(Map Name (Set Region)) + , ssRegionStack :: !(Map (Int, Region) [(Int, AddressState, CallGraph)]) -- HINT: key = threadId + region ; value = index + start + call-graph + , ssRegionInstances :: !(Map Region (IntMap (AddressState, AddressState))) -- region => instance-index => start end + , ssRegionCounter :: !(Map Region Int) -- retainer db - , ssReferenceMap :: !(Map GCSymbol (Set GCSymbol)) - , ssRetainerMap :: !(Map GCSymbol (Set GCSymbol)) - , ssGCRootSet :: !(Set GCSymbol) + , ssReferenceMap :: !(Map GCSymbol (Set GCSymbol)) + , ssRetainerMap :: !(Map GCSymbol (Set GCSymbol)) + , ssGCRootSet :: !(Set GCSymbol) -- tracing - , ssTracingState :: TracingState + , ssTracingState :: TracingState -- origin db - , ssOrigin :: !(IntMap (Id, Int, Int)) -- HINT: closure, closure address, thread id + , ssOrigin :: !(IntMap (Id, Int, Int)) -- HINT: closure, closure address, thread id -- GC marker - , ssGCMarkers :: ![AddressState] + , ssGCMarkers :: ![AddressState] -- tracing primops - , ssTraceEvents :: ![(String, AddressState)] - , ssTraceMarkers :: ![(String, Int, AddressState)] + , ssTraceEvents :: ![(String, AddressState)] + , ssTraceMarkers :: ![(String, Int, AddressState)] -- internal dev mode debug settings - , ssDebugSettings :: DebugSettings + , ssDebugSettings :: DebugSettings } - deriving (Show) + deriving stock (Show) -- for the primop tests fakeStgStateForPrimopTests :: StgState @@ -609,59 +667,59 @@ emptyStgState now isQuiet stateStore dl dbgChan dbgState tracingState debugSetti data Rts = Rts -- data constructors needed for FFI argument boxing from the base library - { rtsCharCon :: DataCon - , rtsIntCon :: DataCon - , rtsInt8Con :: DataCon - , rtsInt16Con :: DataCon - , rtsInt32Con :: DataCon - , rtsInt64Con :: DataCon - , rtsWordCon :: DataCon - , rtsWord8Con :: DataCon - , rtsWord16Con :: DataCon - , rtsWord32Con :: DataCon - , rtsWord64Con :: DataCon - , rtsPtrCon :: DataCon - , rtsFunPtrCon :: DataCon - , rtsFloatCon :: DataCon - , rtsDoubleCon :: DataCon - , rtsStablePtrCon :: DataCon - , rtsTrueCon :: DataCon - , rtsFalseCon :: DataCon + { rtsCharCon :: DataCon + , rtsIntCon :: DataCon + , rtsInt8Con :: DataCon + , rtsInt16Con :: DataCon + , rtsInt32Con :: DataCon + , rtsInt64Con :: DataCon + , rtsWordCon :: DataCon + , rtsWord8Con :: DataCon + , rtsWord16Con :: DataCon + , rtsWord32Con :: DataCon + , rtsWord64Con :: DataCon + , rtsPtrCon :: DataCon + , rtsFunPtrCon :: DataCon + , rtsFloatCon :: DataCon + , rtsDoubleCon :: DataCon + , rtsStablePtrCon :: DataCon + , rtsTrueCon :: DataCon + , rtsFalseCon :: DataCon -- closures used by FFI wrapper code ; heap address of the closure - , rtsUnpackCString :: Atom - , rtsTopHandlerRunIO :: Atom - , rtsTopHandlerRunNonIO :: Atom - , rtsTopHandlerFlushStdHandles :: Atom + -- , rtsUnpackCString :: Atom + , rtsTopHandlerRunIO :: Atom + , rtsTopHandlerRunNonIO :: Atom + , rtsTopHandlerFlushStdHandles :: Atom -- closures used by the exception primitives - , rtsDivZeroException :: Atom - , rtsUnderflowException :: Atom - , rtsOverflowException :: Atom + , rtsDivZeroException :: Atom + , rtsUnderflowException :: Atom + , rtsOverflowException :: Atom -- closures used by the STM primitives - , rtsNestedAtomically :: Atom -- (exception) + , rtsNestedAtomically :: Atom -- (exception) -- closures used by the GC deadlock detection - , rtsBlockedIndefinitelyOnMVar :: Atom -- (exception) - , rtsBlockedIndefinitelyOnSTM :: Atom -- (exception) - , rtsNonTermination :: Atom -- (exception) + , rtsBlockedIndefinitelyOnMVar :: Atom -- (exception) + , rtsBlockedIndefinitelyOnSTM :: Atom -- (exception) + , rtsNonTermination :: Atom -- (exception) -- rts helper custom closures - , rtsApplyFun1Arg :: Atom - , rtsTuple2Proj0 :: Atom + , rtsApplyFun1Arg :: Atom + , rtsTuple2Proj0 :: Atom -- builtin special store, see FFI (i.e. getOrSetGHCConcSignalSignalHandlerStore) - , rtsGlobalStore :: Map Name Atom + , rtsGlobalStore :: Map Name Atom -- program contants - , rtsProgName :: String - , rtsProgArgs :: [String] + , rtsProgName :: String + , rtsProgArgs :: [String] -- native C data symbols - , rtsDataSymbol_enabled_capabilities :: Ptr CInt + , rtsDataSymbol_enabled_capabilities :: Ptr CInt } - deriving (Show) + deriving stock (Show) type M = StateT StgState IO @@ -688,7 +746,7 @@ stackPush sc = do stackPop :: M (Maybe StackContinuation) stackPop = do let tailFun ts@ThreadState{..} = ts {tsStack = drop 1 tsStack} - Just ts@ThreadState{..} <- state $ \s@StgState{..} -> + Just ThreadState{..} <- state $ \s@StgState{..} -> ( IntMap.lookup ssCurrentThreadId ssThreads , s {ssThreads = IntMap.adjust tailFun ssCurrentThreadId ssThreads} ) @@ -700,7 +758,7 @@ stackPop = do freshHeapAddress :: HasCallStack => M Addr freshHeapAddress = do - limit <- gets ssNextHeapAddr + _limit <- gets ssNextHeapAddr state $ \s@StgState{..} -> (ssNextHeapAddr, s {ssNextHeapAddr = succ ssNextHeapAddr}) allocAndStore :: HasCallStack => HeapObject -> M Addr @@ -743,16 +801,15 @@ stgErrorM :: HasCallStack => String -> M a stgErrorM msg = do tid <- gets ssCurrentThreadId liftIO $ do - putStrLn $ " * stgErrorM: " ++ show msg putStrLn $ "current thread id: " ++ show tid reportThread tid curClosure <- gets ssCurrentClosure liftIO $ do + putStrLn $ " * stgErrorM: " ++ show msg putStrLn $ "current closure: " ++ show curClosure putStrLn $ " * native estgi call stack:" putStrLn $ prettyCallStack callStack - action <- unPrintable <$> gets ssStgErrorAction - action + void $ unPrintable <$> gets ssStgErrorAction error "stgErrorM" addBinderToEnv :: StaticOrigin -> Binder -> Atom -> Env -> Env @@ -762,7 +819,7 @@ addZippedBindersToEnv :: StaticOrigin -> [(Binder, Atom)] -> Env -> Env addZippedBindersToEnv so bvList env = foldl' (\e (b, v) -> Map.insert (Id b) (so, v) e) env bvList addManyBindersToEnv :: StaticOrigin -> [Binder] -> [Atom] -> Env -> Env -addManyBindersToEnv so [] [] env = env +addManyBindersToEnv _ [] [] env = env addManyBindersToEnv so (b : binders) (v : values) env = addManyBindersToEnv so binders values $ Map.insert (Id b) (so, v) env addManyBindersToEnv so (b : binders) values env = addManyBindersToEnv so binders values $ Map.insert (Id b) (so, Unbinded (Id b)) env addManyBindersToEnv so binders values _env = error $ "addManyBindersToEnv - length mismatch: " ++ show (so, [(Id b, binderType b, binderTypeSig b) | b <- binders], values) @@ -776,12 +833,12 @@ lookupEnvSO localEnv b = do Just a -> pure a Nothing -> case binderUniqueName b of -- HINT: GHC.Prim module does not exist it's a wired in module - "ghc-prim_GHC.Prim.void#" -> pure (SO_Builtin, Void) - "ghc-prim_GHC.Prim.realWorld#" -> pure (SO_Builtin, Void) - "ghc-prim_GHC.Prim.coercionToken#" -> pure (SO_Builtin, Void) - "ghc-prim_GHC.Prim.proxy#" -> pure (SO_Builtin, Void) - "ghc-prim_GHC.Prim.(##)" -> pure (SO_Builtin, Void) - _ -> stgErrorM $ "unknown variable: " ++ show b + "ghc-prim_GHC.Prim.void#" -> pure (SO_Builtin, Void) + "ghc-prim_GHC.Prim.realWorld#" -> pure (SO_Builtin, Void) + "ghc-prim_GHC.Prim.coercionToken#" -> pure (SO_Builtin, Void) + "ghc-prim_GHC.Prim.proxy#" -> pure (SO_Builtin, Void) + "ghc-prim_GHC.Prim.(##)" -> pure (SO_Builtin, Void) + _ -> stgErrorM $ "unknown variable: " ++ show b lookupEnv :: HasCallStack => Env -> Binder -> M Atom lookupEnv localEnv b = snd <$> lookupEnvSO localEnv b @@ -802,7 +859,7 @@ readHeapCon a = readHeap a >>= \o -> case o of readHeapClosure :: HasCallStack => Atom -> M HeapObject readHeapClosure a = readHeap a >>= \o -> case o of Closure{} -> pure o - _ -> stgErrorM $ "expected closure but got: "-- ++ show o + _ -> stgErrorM $ "expected closure but got: "-- ++ show o -- primop related @@ -923,7 +980,7 @@ markClosure :: Name -> M () markClosure n = modify' $ \s@StgState{..} -> s {ssEvaluatedClosures = setInsert n ssEvaluatedClosures} markExecuted :: Int -> M () -markExecuted i = pure () -- modify' $ \s@StgState{..} -> s {ssExecutedClosures = setInsert i ssExecutedClosures} +markExecuted _ = pure () -- modify' $ \s@StgState{..} -> s {ssExecutedClosures = setInsert i ssExecutedClosures} markExecutedId :: Id -> M () markExecutedId i = modify' $ \s@StgState{..} -> s {ssExecutedClosureIds = setInsert i ssExecutedClosureIds} @@ -965,7 +1022,7 @@ addIntraClosureCallGraphEdge from so to = do } setProgramPoint :: ProgramPoint -> M () -setProgramPoint pp = modify' $ \s@StgState{..} -> s {ssCurrentProgramPoint = pp} +setProgramPoint pp = modify' $ \s -> s {ssCurrentProgramPoint = pp} -- string constants -- NOTE: the string gets extended with a null terminator @@ -984,24 +1041,24 @@ getCStringConstantPtrAtom key = do --------------------------------------------- -- stm -promptM :: IO () -> M () +promptM :: HasCallStack => IO () -> M () promptM ioAction = do isQuiet <- gets ssIsQuiet - tid <- gets ssCurrentThreadId + -- tid <- gets ssCurrentThreadId pp <- gets ssCurrentProgramPoint - cc <- gets ssCurrentClosure - tsList <- gets $ IntMap.toList . ssThreads + _cc <- gets ssCurrentClosure + -- tsList <- gets $ IntMap.toList . ssThreads liftIO . unless isQuiet $ do - now <- getCurrentTime - putStrLn $ " now = " ++ show now - putStrLn $ " tid = " ++ show tid ++ " thread status list: " ++ show [(tid, tsStatus ts) | (tid, ts) <- tsList] + -- now <- getCurrentTime + -- putStrLn $ " now = " ++ show now + -- putStrLn $ " tid = " ++ show tid ++ " thread status list: " ++ show [(tid', tsStatus ts) | (tid', ts) <- tsList] putStrLn $ " program point = " ++ show pp ioAction --putStrLn "[press enter]" --getLine pure () -promptM_ :: M () -> M () +promptM_ :: HasCallStack => M () -> M () promptM_ ioAction = do isQuiet <- gets ssIsQuiet unless isQuiet $ do @@ -1012,10 +1069,10 @@ promptM_ ioAction = do data TLogEntry = TLogEntry - { tleObservedGlobalValue :: !Atom - , tleCurrentLocalValue :: !Atom + { tleObservedGlobalValue :: !Atom + , tleCurrentLocalValue :: !Atom } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) type TLog = IntMap TLogEntry @@ -1049,7 +1106,7 @@ unsubscribeTVarWaitQueues tid tlog = do data AsyncExceptionMask = NotBlocked | Blocked {isInterruptible :: !Bool} - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) data ThreadState = ThreadState @@ -1068,7 +1125,7 @@ data ThreadState , tsActiveTLog :: !(Maybe TLog) -- elems: (global value, local value) , tsTLogStack :: ![TLog] } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) -- thread operations @@ -1179,14 +1236,14 @@ data BlockReason | BlockedOnRead Int -- file descriptor | BlockedOnWrite Int -- file descriptor | BlockedOnDelay UTCTime -- target time to wake up thread - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) data ThreadStatus = ThreadRunning | ThreadBlocked BlockReason | ThreadFinished -- RTS name: ThreadComplete | ThreadDied -- RTS name: ThreadKilled - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) isThreadLive :: ThreadStatus -> Bool isThreadLive = \case @@ -1288,7 +1345,7 @@ reportThread tid = do reportThreadIO :: Int -> ThreadState -> IO () reportThreadIO tid endTS = do putStrLn "" - putStrLn $ show ("tid", tid, "tsStatus", tsStatus endTS) + print ("tid" :: String, tid, "tsStatus" :: String, tsStatus endTS) Text.putStrLn $ pShowNoColor endTS putStrLn "" @@ -1302,21 +1359,21 @@ showStackCont = \case data RefSet = RefSet - { rsHeap :: !IntSet - , rsWeakPointers :: !IntSet - , rsTVars :: !IntSet - , rsMVars :: !IntSet - , rsMutVars :: !IntSet - , rsArrays :: !IntSet - , rsMutableArrays :: !IntSet - , rsSmallArrays :: !IntSet - , rsSmallMutableArrays :: !IntSet - , rsArrayArrays :: !IntSet - , rsMutableArrayArrays :: !IntSet - , rsMutableByteArrays :: !IntSet - , rsStableNames :: !IntSet - , rsStablePointers :: !IntSet - , rsThreads :: !IntSet + { rsHeap :: !IntSet + , rsWeakPointers :: !IntSet + , rsTVars :: !IntSet + , rsMVars :: !IntSet + , rsMutVars :: !IntSet + , rsArrays :: !IntSet + , rsMutableArrays :: !IntSet + , rsSmallArrays :: !IntSet + , rsSmallMutableArrays :: !IntSet + , rsArrayArrays :: !IntSet + , rsMutableArrayArrays :: !IntSet + , rsMutableByteArrays :: !IntSet + , rsStableNames :: !IntSet + , rsStablePointers :: !IntSet + , rsThreads :: !IntSet } emptyRefSet :: RefSet @@ -1357,7 +1414,7 @@ data AddressState , asNextArrayArray :: !Int , asNextMutableArrayArray :: !Int } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) emptyAddressState :: AddressState emptyAddressState = AddressState @@ -1409,7 +1466,7 @@ data Region | EventRegion { regionName :: Name } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) -- let-no-escape statistics markLNE :: [Addr] -> M () @@ -1423,7 +1480,7 @@ data ProgramPoint = PP_Global | PP_Apply Int ProgramPoint | PP_StgPoint StgPoint - deriving (Eq, Ord, Read, Show) + deriving stock (Eq, Ord, Read, Show) dumpStgState :: M () dumpStgState = do @@ -1492,7 +1549,7 @@ wakeupBlackHoleQueueThreads addr = readHeap (HeapPtr addr) >>= \case forM_ hoBHWaitQueue $ \waitingTid -> do waitingTS <- getThreadState waitingTid case tsStatus waitingTS of - ThreadBlocked (BlockedOnBlackHole dstAddr) -> do + ThreadBlocked (BlockedOnBlackHole _dstAddr) -> do updateThreadState waitingTid (waitingTS {tsStatus = ThreadRunning}) _ -> error $ "internal error - invalid thread status: " ++ show (tsStatus waitingTS) x -> error $ "internal error - expected BlackHole, got: " ++ show x diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debug.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debug.hs index cc1d14d..93d4169 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debug.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debug.hs @@ -1,29 +1,44 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} + module Stg.Interpreter.Debug where -import qualified GHC.Exts as Exts -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.Primitive.ByteArray as BA -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Map as Map -import qualified Data.Map.Strict as StrictMap -import Data.List (intercalate, foldl', sortOn) -import System.IO -import System.Directory -import System.FilePath -import Text.Printf - -import Control.Monad.State.Strict - -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative ((<$>)) +import Control.Monad (Functor (..), forM_, mapM_, unless) +import Control.Monad.State.Strict (MonadIO (..), gets) + +import Data.Bool (Bool (..)) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Internal as BS +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List (intercalate, maximum, minimum, null, sortOn, sum, (++)) +import qualified Data.Map.Strict as StrictMap +import Data.Ord (Ord (..)) +import qualified Data.Primitive.ByteArray as BA +import qualified Data.Set as Set +import Data.String (unlines) +import Data.Tuple (snd) + +import qualified GHC.Exts as Exts +import GHC.Num (Num (..)) + +import Stg.Interpreter.Base (ByteArrayDescriptor (..), CallGraph (..), EvalOnNewThread, HeapObject (..), + M, Region (..), Rts (..), StaticOrigin (..), StgState (..)) +import Stg.Syntax (Binder (..), DC (..), DataCon (..), Id (Id), getModuleName, getUnitId) + +import System.Directory (createDirectoryIfMissing, makeAbsolute) +import System.FilePath (()) +import System.IO (FilePath, IO, IOMode (..), hPutStrLn, print, putStrLn, withFile) + +import Text.Printf (printf) +import Text.Show (Show (..)) + showCons :: Int -> M () showCons addr = do h <- gets ssHeap - liftIO $ mapM_ print [(i, dcUniqueName $ unDC dc, args) | x@(i, c@(Con _ dc args)) <- IntMap.toAscList h, i >= addr] + liftIO $ mapM_ print [(i, dcUniqueName $ unDC dc, args) | (i, Con _ dc args) <- IntMap.toAscList h, i >= addr] {- | Closure @@ -54,7 +69,7 @@ showClosures addr = do h <- gets ssHeap executed <- gets ssExecutedClosures let thunks = [x | x@(i, Closure{..}) <- IntMap.toAscList h, i >= addr, Set.notMember i executed, hoCloMissing == 0] - liftIO $ mapM_ print [(i, getUnitId binderUnitId, getModuleName binderModule, hoName, hoCloMissing, hoCloArgs) | x@(i, c@Closure{..}) <- thunks, let Id Binder{..} = hoName] + liftIO $ mapM_ print [(i, getUnitId binderUnitId, getModuleName binderModule, hoName, hoCloMissing, hoCloArgs) | (i, Closure{..}) <- thunks, let Id Binder{..} = hoName] {- forM_ thunks $ \(i, _) -> do liftIO $ do @@ -77,7 +92,7 @@ showByteArrays :: M () showByteArrays = do arrs <- gets ssMutableByteArrays liftIO $ forM_ (IntMap.toList arrs) $ \(i, ByteArrayDescriptor{..}) -> do - arr <- map BS.w2c . Exts.toList <$> BA.unsafeFreezeByteArray baaMutableByteArray + arr <- fmap BS.w2c . Exts.toList <$> BA.unsafeFreezeByteArray baaMutableByteArray print (i, arr) putStrLn "\n-------------------------------------------\n" {- @@ -100,8 +115,8 @@ showMarked = do mapM_ print prims showDebug :: EvalOnNewThread -> M () -showDebug evalOnNewThread = do - limit <- gets ssDynamicHeapStart +showDebug _evalOnNewThread = do + _limit <- gets ssDynamicHeapStart liftIO $ putStrLn "\n-------------------------------------------\n" liftIO $ putStrLn "Used primops and foreign functions:" liftIO $ putStrLn "\n-------------------------------------------\n" @@ -181,7 +196,7 @@ writeCallGraph fname CallGraph{..} = do , show from , show to ] - forM_ (sortOn (negate . snd) $ StrictMap.toList cgIntraClosureCallGraph) $ \((from, so, to), count) -> do + forM_ (sortOn (negate . snd) $ StrictMap.toList cgIntraClosureCallGraph) $ \((from, _so, to), count) -> do hPutStrLn h $ intercalate "\t" [ show count , "direct" diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs index 04b91dc..ad641f2 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs @@ -1,19 +1,34 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.Debugger where -import GHC.Stack -import Control.Monad.State -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap +import Control.Applicative (Applicative (..)) import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi -import Control.Concurrent.MVar +import Control.Concurrent.MVar (putMVar, takeMVar, tryTakeMVar) +import Control.Monad (Functor (..), Monad (..), unless) +import Control.Monad.State (MonadIO (..), gets, modify') + +import Data.Bool (Bool (..), otherwise) +import Data.Function (($)) +import qualified Data.IntMap as IntMap +import Data.List ((++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), maybe) +import Data.Ord (Ord (..)) +import qualified Data.Set as Set + +import GHC.Stack (HasCallStack) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base (Atom (..), Breakpoint, DebugCommand (..), DebugEvent (..), + DebugOutput (..), DebugState (..), DebuggerChan (..), M, + StgState (..), readHeap) +import Stg.Interpreter.Debugger.Internal (runInternalCommand) + +import System.IO (putStrLn) -import Stg.Interpreter.Base -import Stg.Syntax -import Stg.IRLocation +import Text.Show (Show (..)) -import Stg.Interpreter.Debugger.Internal sendDebugEvent :: DebugEvent -> M () sendDebugEvent dbgEvent = do @@ -42,7 +57,7 @@ runDebugCommand cmd = do liftIO $ putMVar dbgSyncResponse $ DbgOutCurrentClosure currentClosure currentClosureAddr closureEnv CmdClearClosureList -> do - modify' $ \s@StgState{..} -> s {ssEvaluatedClosures = Set.empty} + modify' $ \s -> s {ssEvaluatedClosures = Set.empty} liftIO $ putMVar dbgSyncResponse DbgOut CmdListClosures -> do @@ -60,24 +75,23 @@ runDebugCommand cmd = do CmdStep -> liftIO $ putMVar dbgSyncResponse DbgOut CmdContinue -> do - modify' $ \s@StgState{..} -> s {ssDebugState = DbgRunProgram} + modify' $ \s -> s {ssDebugState = DbgRunProgram} liftIO $ putMVar dbgSyncResponse DbgOut CmdPeekHeap addr -> do heap <- gets ssHeap - case IntMap.member addr heap of - True -> do - ho <- readHeap $ HeapPtr addr - liftIO $ putMVar dbgSyncResponse $ DbgOutHeapObject addr ho - False -> do - liftIO $ putMVar dbgSyncResponse DbgOut + if IntMap.member addr heap then do + ho <- readHeap $ HeapPtr addr + liftIO $ putMVar dbgSyncResponse $ DbgOutHeapObject addr ho + else + liftIO $ putMVar dbgSyncResponse DbgOut CmdStop -> do - modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep} + modify' $ \s -> s {ssDebugState = DbgStepByStep} liftIO $ putMVar dbgSyncResponse DbgOut - CmdInternal cmd -> do - runInternalCommand cmd + CmdInternal cmd' -> do + runInternalCommand cmd' isDebugExitCommand :: DebugCommand -> Bool isDebugExitCommand = \case @@ -99,9 +113,7 @@ processCommandsUntilExit :: M () processCommandsUntilExit = do cmd <- getNextDebugCommand runDebugCommand cmd - if isDebugExitCommand cmd - then pure () - else processCommandsUntilExit + unless (isDebugExitCommand cmd) processCommandsUntilExit hasFuel :: M Bool hasFuel = do @@ -111,7 +123,7 @@ hasFuel = do checkBreakpoint :: [Atom] -> Breakpoint -> M () checkBreakpoint localEnv breakpoint = do - modify' $ \s@StgState{..} -> s {ssLocalEnv = localEnv} + modify' $ \s -> s {ssLocalEnv = localEnv} dbgState <- gets ssDebugState exit <- processCommandsNonBlocking shouldStep <- hasFuel @@ -120,7 +132,7 @@ checkBreakpoint localEnv breakpoint = do sendDebugEvent DbgEventStopped unless exit processCommandsUntilExit DbgRunProgram -> do - unless shouldStep $ modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep} + unless shouldStep $ modify' $ \s -> s {ssDebugState = DbgStepByStep} bkMap <- gets ssBreakpoints case Map.lookup breakpoint bkMap of Nothing -> pure () @@ -132,7 +144,7 @@ checkBreakpoint localEnv breakpoint = do | otherwise -> do -- HINT: trigger breakpoint liftIO $ putStrLn $ "hit breakpoint: " ++ show breakpoint - Just currentClosure <- gets ssCurrentClosure + Just _currentClosure <- gets ssCurrentClosure sendDebugEvent $ DbgEventHitBreakpoint breakpoint - modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep} + modify' $ \s -> s {ssDebugState = DbgStepByStep} unless exit processCommandsUntilExit diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Datalog.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Datalog.hs index 8afdaaf..df70e7b 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Datalog.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Datalog.hs @@ -1,31 +1,42 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.Debugger.Datalog (exportStgState) where -import Control.Monad -import Control.Monad.State -import Control.Monad.Reader -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Data.IntMap (IntMap) -import qualified Data.IntSet as IntSet -import qualified Data.ByteString.Char8 as BS8 -import Data.Vector (Vector) -import qualified Data.Vector as V +import Control.Applicative (Applicative (..)) +import Control.Monad (forM, forM_, mapM, mapM_, void) +import Control.Monad.State (MonadIO (..), MonadState (..), StateT, execStateT) + +import Data.Bool (Bool (..)) +import qualified Data.ByteString.Char8 as BS8 +import Data.Function (flip, ($)) +import Data.Int (Int) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.List (intercalate, length, nub, reverse, zip, (++)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), maybeToList) import qualified Data.Primitive.ByteArray as BA -import Data.Maybe -import Data.List (intercalate, nub) -import Text.Printf +import Data.String (String) +import Data.Tuple (snd) +import Data.Vector (Vector) +import qualified Data.Vector as V -import System.Directory -import System.FilePath -import System.IO +import GHC.Err (error) -import qualified Stg.Interpreter.GC as GC +import Stg.Interpreter.Base (AddressState (..), ArrIdx (..), ArrayArrIdx (..), Atom (..), + ByteArrayDescriptor (..), ByteArrayIdx (baId), HeapObject (..), + MVarDescriptor (..), PtrOrigin (..), Region (..), SmallArrIdx (..), + StackContinuation (..), StgState (..), TVarDescriptor (..), ThreadState (..), + WeakPtrDescriptor (..), convertAddressState, debugPrintHeapObject, + showStackCont) +import Stg.Syntax (Binder (..), DC (..), DataCon (..), Id (..), Name, getModuleName, getUnitId) -import Stg.Interpreter.Base -import Stg.Syntax +import System.Directory (createDirectoryIfMissing, makeAbsolute) +import System.FilePath (FilePath, ()) +import System.IO (Handle, IO, IOMode (..), hClose, hPutStrLn, openFile, putStrLn) + +import Text.Printf (printf) +import Text.Show (Show (..)) data Param @@ -35,7 +46,7 @@ data Param | A Atom | ID Id -data DLExport +newtype DLExport = DLExport { dleHandleMap :: Map Name Handle } @@ -46,7 +57,7 @@ getHandle :: Name -> DL Handle getHandle n = do DLExport{..} <- get case Map.lookup n dleHandleMap of - Just h -> pure h + Just h -> pure h Nothing -> error $ "missing handle for: " ++ show n genParam :: Param -> DL String @@ -107,7 +118,7 @@ emitAtomToRef a = do StableName i -> add $ printf "$R_StableName\t%d" i PtrAtom (StablePtr i) _ -> add $ printf "$R_StablePointer\t%d" i ThreadId i -> add $ printf "$R_ThreadId\t%d" i - _ -> pure () + _ -> pure () arrIdxToRef :: ArrIdx -> String arrIdxToRef = \case @@ -154,7 +165,8 @@ exportStgStateM stgState@StgState{..} = do addFact "StableName" [I i, A a] forM_ (IntMap.toList ssMutableByteArrays) $ \(i, ByteArrayDescriptor{..}) -> do - addFact "MutableByteArray" [I i, S (show baaPinned), I baaAlignment, I $ BA.sizeofMutableByteArray baaMutableByteArray] + sz <- BA.getSizeofMutableByteArray baaMutableByteArray + addFact "MutableByteArray" [I i, S (show baaPinned), I baaAlignment, I sz] -- mvars forM_ (IntMap.toList ssMVars) $ \(i, mv@MVarDescriptor{..}) -> do @@ -246,7 +258,7 @@ exportStgStateM stgState@StgState{..} = do IRRegion{..} -> (regionStart, regionEnd) EventRegion{..} -> (regionName, regionName) forM_ (IntMap.toList l) $ \(idx, (s, e)) -> do - forM_ (zip (genAddressState s) (genAddressState e)) $ \((start_ns, start_value), (end_ns, end_value)) -> do + forM_ (zip (genAddressState s) (genAddressState e)) $ \((start_ns, start_value), (_end_ns, end_value)) -> do addFact "Region" [N start_name, N end_name, I idx, S start_ns, I start_value, I end_value] -- ssDynamicHeapStart @@ -376,7 +388,7 @@ exportStgState dbFolder s = do putStrLn $ "save StgState datalog facts to: " ++ dir createDirectoryIfMissing True dir hMap <- mkHandles dir allFactNames - DLExport{..} <- execStateT (exportStgStateM s) $ DLExport + void $ execStateT (exportStgStateM s) $ DLExport { dleHandleMap = hMap } mapM_ hClose $ Map.elems hMap diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs index 428c53d..70123da 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs @@ -1,30 +1,42 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, TupleSections #-} module Stg.Interpreter.Debugger.Internal where -import Text.Printf -import qualified Text.Read as Text -import Control.Monad.State -import qualified Data.List as List -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.ByteString.Char8 as BS8 -import Data.Tree -import System.Console.Pretty - -import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi -import Control.Concurrent (myThreadId) -import Control.Concurrent.MVar - -import Stg.Interpreter.Base -import Stg.Syntax - -import qualified Stg.Interpreter.GC as GC -import qualified Stg.Interpreter.GC.GCRef as GC -import Stg.Interpreter.Debugger.Region -import Stg.Interpreter.GC.RetainerAnalysis -import Stg.Interpreter.Debugger.Datalog +import Control.Applicative (Applicative (..), (<$>)) +import Control.Concurrent (myThreadId) +import Control.Concurrent.MVar (putMVar) +import Control.Monad (Functor (..), Monad (..), forM_, mapM, unless) +import Control.Monad.State (MonadIO (..), MonadState (get), gets, modify') + +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (const, ($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.List (foldr, length, maximum, reverse, take, (++)) +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import qualified Data.Set as Set +import Data.String (String, unlines, words) +import Data.Tree (Tree, drawTree, unfoldTreeM) + +import Stg.Interpreter.Base (AddressState (..), DebugOutput (..), DebuggerChan (..), GCSymbol, + M, StgState (..), debugPrintHeapObject, getThreadState) +import Stg.Interpreter.Debugger.Datalog (exportStgState) +import Stg.Interpreter.Debugger.Region (addRegion, delRegion, dumpHeapM, dumpHeapObject, getRegionHeap, + showRegion) +import qualified Stg.Interpreter.GC as GC +import qualified Stg.Interpreter.GC.GCRef as GC +import Stg.Interpreter.GC.RetainerAnalysis (clearRetanerDb, loadRetainerDb2) +import Stg.Syntax (Binder (..), Id (..)) + +import System.Console.Pretty (Color (..), Pretty (..), Style (..)) +import System.IO (print, putStrLn) + +import Text.Printf (printf) +import qualified Text.Read as Text +import Text.Show (Show (..)) + showOriginTrace :: Int -> M () showOriginTrace i = do @@ -96,7 +108,7 @@ decodeAndShow dlRef = do rootSet <- gets ssGCRootSet let showOrigin = \case Nothing -> "" - Just (oId,oAddr,_) -> (color White $ style Bold " ORIGIN: ") ++ (color Green $ show oId) ++ " " ++ show oAddr + Just (oId,oAddr,_) -> color White (style Bold " ORIGIN: ") ++ color Green (show oId) ++ " " ++ show oAddr showHeapObj = \case Nothing -> "" Just ho -> " " ++ debugPrintHeapObject ho @@ -130,28 +142,28 @@ dbgCommands :: [([String], String, [String] -> M ())] dbgCommands = [ ( ["gc"] , "run sync. garbage collector" - , wrapWithDbgOut $ \_ -> do + , wrapWithDbgOut $ const $ do localEnv <- gets ssLocalEnv GC.runGCSync localEnv ) , ( ["cleardb"] , "clear retainer db" - , wrapWithDbgOut $ \_ -> clearRetanerDb + , wrapWithDbgOut $ const clearRetanerDb ) , ( ["loaddb"] , "load retainer db" - , wrapWithDbgOut $ \_ -> loadRetainerDb2 + , wrapWithDbgOut $ const loadRetainerDb2 ) , ( ["?"] , "show debuggers' all internal commands" - , wrapWithDbgOut $ \_ -> printHelp + , wrapWithDbgOut $ const printHelp ) , ( ["report"] , "report some internal data" - , wrapWithDbgOut $ \_ -> do + , wrapWithDbgOut $ const $ do heapStart <- gets ssDynamicHeapStart liftIO $ do putStrLn $ "heap start address: " ++ show heapStart @@ -161,15 +173,15 @@ dbgCommands = , "queries a given list of NAME_PATTERNs in static global env as substring" , wrapWithDbgOut $ \patterns -> do env <- gets ssStaticGlobalEnv - let filterPattern pat resultList = [n | n <- resultList, List.isInfixOf pat n] - matches = foldr filterPattern (map show $ Map.keys env) patterns + let filterPattern pat resultList = [n | n <- resultList, pat `List.isInfixOf` n] + matches = foldr filterPattern (fmap show $ Map.keys env) patterns liftIO $ putStrLn $ unlines matches ) , ( ["?b"] , "list breakpoints" , wrapWithDbgOut $ \_ -> do - bks <- Map.toList <$> gets ssBreakpoints + bks <- gets (Map.toList . ssBreakpoints) liftIO $ putStrLn $ unlines [printf "%-40s %d [fuel]" (show name) fuel | (name, fuel) <- bks] ) @@ -177,8 +189,8 @@ dbgCommands = , "[START] [END] list a given region or all regions if the arguments are omitted" , wrapWithDbgOut $ \case [] -> do - regions <- Map.keys <$> gets ssRegionStack - liftIO $ putStrLn $ unlines $ map show regions + regions <- gets (Map.keys . ssRegionStack) + liftIO $ putStrLn $ unlines $ fmap show regions [start] -> showRegion False start start [start, end] -> showRegion False start end _ -> pure () @@ -313,10 +325,10 @@ dbgCommands = , "STEP-COUNT - make multiple steps ; 'fuel -' - turn off step count check" , wrapWithDbgOut $ \case ["-"] - -> modify' $ \s@StgState{..} -> s {ssDebugFuel = Nothing} + -> modify' $ \s -> s {ssDebugFuel = Nothing} [countS] | Just stepCount <- Text.readMaybe countS - -> modify' $ \s@StgState{..} -> s {ssDebugFuel = Just stepCount} + -> modify' $ \s -> s {ssDebugFuel = Just stepCount} _ -> pure () ) @@ -331,12 +343,12 @@ dbgCommands = , ( ["get-current-thread-state"] , "reports the currently running thread state" - , \_ -> reportStateSync + , const reportStateSync ) , ( ["get-stg-state"] , "reports the stg state" - , \_ -> reportStgStateSync + , const reportStgStateSync ) ] @@ -349,7 +361,7 @@ flatCommands = [(cmd, desc, action) | (tokens, desc, action) <- dbgCommands, cmd printHelp :: M () printHelp = do - let maxLen = maximum $ map length [c | (c, _, _) <- flatCommands] + let maxLen = maximum $ fmap length [c | (c, _, _) <- flatCommands] liftIO $ putStrLn "internal debugger commands:" forM_ flatCommands $ \(cmd, desc, _) -> do liftIO $ printf (" %-" ++ show maxLen ++ "s - %s\n") cmd desc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Region.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Region.hs index d2b8432..5c82eb3 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Region.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Region.hs @@ -1,23 +1,41 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.Debugger.Region where -import Text.Printf -import Control.Monad.State -import Data.Maybe -import qualified Data.List as List -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.ByteString.Char8 as BS8 -import System.Console.Pretty - -import Stg.Interpreter.Base -import Stg.Interpreter.Debug -import Stg.Syntax - -import qualified Stg.Interpreter.GC as GC +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..), forM_, unless, when) +import Control.Monad.State (MonadIO (..), gets, modify, modify') + +import Data.Bool (Bool, otherwise, (&&)) +import qualified Data.ByteString.Char8 as BS8 +import Prelude (Enum (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List ((++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), fromMaybe) +import Data.Monoid (Monoid (..)) +import qualified Data.Set as Set +import Data.String (String, words) +import Data.Tuple (fst, snd) + +import GHC.Err (error) +import GHC.Num (Num (..)) + +import Stg.Interpreter.Base (AddressState (..), Heap, HeapObject, M, Region (..), StgState (..), + debugPrintHeapObject, emptyCallGraph, getAddressState, joinCallGraph) +import Stg.Interpreter.Debug (exportRegionCallGraph) +import qualified Stg.Interpreter.GC as GC import qualified Stg.Interpreter.GC.GCRef as GC +import Stg.Syntax (Name) + +import System.Console.Pretty (Color (..), Pretty (..), Style (..)) +import System.IO (putStrLn) + +import Text.Printf (printf) +import Text.Show (Show (..)) + evalRegionCommand :: String -> M () evalRegionCommand cmd = do @@ -25,7 +43,7 @@ evalRegionCommand cmd = do case words cmd of ["estgi.debug.region.start", name] -> startRegion tid . EventRegion $ BS8.pack name ["estgi.debug.region.end", name] -> endRegion tid . EventRegion $ BS8.pack name - _ -> pure () + _ -> pure () dumpHeapObject :: Int -> HeapObject -> String dumpHeapObject i o = printf "%-8d %3s %s" i (GC.ppLNE o) (debugPrintHeapObject o) @@ -34,8 +52,8 @@ dumpOriginM :: Int -> M String dumpOriginM i = do origin <- gets ssOrigin case IntMap.lookup i origin of - Nothing -> pure "" - Just (oId,oAddr,_) -> pure $ (color White $ style Bold " ORIGIN: ") ++ (color Green $ show oId) ++ " " ++ show oAddr + Nothing -> pure "" + Just (oId,oAddr,_) -> pure $ color White (style Bold " ORIGIN: ") ++ color Green (show oId) ++ " " ++ show oAddr dumpHeapM :: Heap -> M () dumpHeapM h = do @@ -114,14 +132,16 @@ checkRegion markerName = do case Map.lookup markerName markers of Nothing -> pure () Just rl -> do - forM_ rl $ \r@(IRRegion s e) -> case r of - _ | markerName == s && markerName == e -> endRegion tid r >> startRegion tid r - _ | markerName == s -> startRegion tid r - _ | markerName == e -> endRegion tid r + forM_ rl $ \r -> case r of + (IRRegion s e) -> if | markerName == s && markerName == e -> endRegion tid r >> startRegion tid r + | markerName == s -> startRegion tid r + | markerName == e -> endRegion tid r + | otherwise -> error "" + EventRegion _ -> error "" nextRegionIndex :: Region -> M Int nextRegionIndex r = do - idx <- fromMaybe 0 <$> gets (Map.lookup r . ssRegionCounter) + idx <- gets (fromMaybe 0 . Map.lookup r . ssRegionCounter) modify' $ \s@StgState{..} -> s {ssRegionCounter = Map.insert r (succ idx) ssRegionCounter} pure idx diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Retainer.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Retainer.hs index cece0ba..8ab8c44 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Retainer.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Retainer.hs @@ -1,29 +1,41 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.Debugger.Retainer ( exportRetainerGraph -- , exportRetainerDominatorTree ) where -import Control.Monad.Writer -import Control.Monad.State -import Data.Maybe -import Data.Bimap ( Bimap ) -import qualified Data.Bimap as Bimap -import Data.Map (Map) -import Data.Set (Set) -import Data.IntMap.Strict (IntMap) -import Data.IntSet (IntSet) -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Graph.Dom as Graph -import System.IO -import Stg.Interpreter.Base -import Stg.Interpreter.GC.GCRef -import Stg.Interpreter.GC.LiveDataAnalysis -import Stg.Interpreter.Debugger.TraverseState +import Control.Applicative (Applicative (..)) +import Control.Monad (forM_, when) +import Control.Monad.State (MonadState (..), StateT, evalStateT, execStateT, gets, modify') +import Control.Monad.Writer (MonadIO (..), MonadWriter (..), execWriter) + +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Bool (Bool (..), not, otherwise) +import qualified Data.ByteString.Char8 as BS8 +import Data.Function (flip, id, ($), (.)) +import Data.Int (Int) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List (drop, (++)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), mapMaybe, maybe) +import Data.Monoid (Monoid (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (String) + +import Stg.Interpreter.Base (GCSymbol (..), StgState (..)) +import Stg.Interpreter.Debugger.TraverseState (getHeapObjectCategory, getHeapObjectSummary) +import Stg.Interpreter.GC.GCRef (RefNamespace (..), decodeRef) +import Stg.Interpreter.GC.LiveDataAnalysis (withGCRootFacts, withReferenceFacts) + +import System.IO (FilePath, Handle, IO, IOMode (..), hPutStr, print, withFile) + +import Text.Show (Show (..)) + data RetainerState @@ -61,25 +73,24 @@ exportRetainerGraph nodesFname edgesFname stgState root = do let gcRootSet :: Map GCSymbol String gcRootSet = execWriter $ withGCRootFacts stgState (ssLocalEnv stgState) $ \msg s -> tell $ Map.singleton s msg - withFile edgesFname WriteMode $ \hEdge -> do - withFile nodesFname WriteMode $ \hNode -> do - BS8.hPutStrLn hNode $ BS8.intercalate "\t" - [ "Id" - , "Label" - , "partition2" - ] - BS8.hPutStrLn hEdge $ BS8.intercalate "\t" - [ "Source" - , "Target" - , "partition2" - ] - flip evalStateT Set.empty . addEdgesFrom hNode hEdge stgState gcRootSet root True $ \case - source - | Just i <- Bimap.lookup source rsNodeMap - , Just edges <- IntMap.lookup i rsGraph - -> catMaybes $ map (flip Bimap.lookupR rsNodeMap) $ IntSet.toList edges - | otherwise - -> [] + withFile edgesFname WriteMode $ \hEdge -> withFile nodesFname WriteMode $ \hNode -> do + BS8.hPutStrLn hNode $ BS8.intercalate "\t" + [ "Id" + , "Label" + , "partition2" + ] + BS8.hPutStrLn hEdge $ BS8.intercalate "\t" + [ "Source" + , "Target" + , "partition2" + ] + flip evalStateT Set.empty . addEdgesFrom hNode hEdge stgState gcRootSet root True $ \case + source + | Just i <- Bimap.lookup source rsNodeMap + , Just edges <- IntMap.lookup i rsGraph + -> (mapMaybe (`Bimap.lookupR` rsNodeMap) (IntSet.toList edges)) + | otherwise + -> [] pure () @@ -109,8 +120,7 @@ addEdgesFrom hNode hEdge stgState@StgState{..} gcRootSet source isRoot getEdges BS8.hPut hNode "\t" hPutStr hNode $ (if isRoot then ("Root " ++) else id) $ - (maybe id (\msg str -> "GCRoot " ++ msg ++ " " ++ str) $ Map.lookup source gcRootSet) $ - nodeLabel + maybe id (\msg str -> "GCRoot " ++ msg ++ " " ++ str) (Map.lookup source gcRootSet) nodeLabel BS8.hPut hNode "\t" hPutStr hNode nodeCategory BS8.hPut hNode "\n" @@ -147,4 +157,4 @@ exportRetainerDominatorTree nodesFname edgesFname stgState root = do , "Target" , "partition2" ] --} \ No newline at end of file +-} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/TraverseState.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/TraverseState.hs index 7fcc23f..f96b888 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/TraverseState.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/TraverseState.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.Debugger.TraverseState ( exportReachableGraph , exportHeapGraph @@ -6,14 +5,29 @@ module Stg.Interpreter.Debugger.TraverseState , getHeapObjectCategory ) where -import Control.Monad.State -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.ByteString.Char8 as BS8 -import System.IO -import Stg.Interpreter.Base -import Stg.Interpreter.GC.GCRef +import Control.Applicative (Applicative (..)) +import Control.Monad (forM_, when) +import Control.Monad.State (MonadIO (..), MonadState (..), StateT, evalStateT) + +import Data.Bool (Bool (..), not) +import qualified Data.ByteString.Char8 as BS8 +import Data.Eq (Eq (..)) +import Data.Function (flip, ($)) +import qualified Data.IntMap as IntMap +import Data.List (drop, (++)) +import Data.Maybe (Maybe (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (String) + +import GHC.Err (error) + +import Stg.Interpreter.Base (GCSymbol (..), Heap, HeapObject (..), StgState (..)) +import Stg.Interpreter.GC.GCRef (RefNamespace (..), VisitGCRef (..), decodeRef, encodeRef) + +import System.IO (FilePath, Handle, IO, IOMode (..), hPutStr, print, withFile) + +import Text.Show (Show (..)) {- export GCSymbol's reachability graph as gephi compatible .tsv file @@ -86,26 +100,26 @@ addEdgesFrom hNode hEdge stgState@StgState{..} source isRoot = do addEdgesFrom hNode hEdge stgState target False case ns of - NS_Array -> emitEdge $ IntMap.lookup idx ssArrays - NS_ArrayArray -> emitEdge $ IntMap.lookup idx ssArrayArrays - NS_HeapPtr -> emitEdge $ IntMap.lookup idx ssHeap - NS_MutableArray -> emitEdge $ IntMap.lookup idx ssMutableArrays - NS_MutableArrayArray -> emitEdge $ IntMap.lookup idx ssMutableArrayArrays - NS_MutableByteArray -> pure () -- IntMap.lookup idx ssMutableByteArrays - NS_MutVar -> emitEdge $ IntMap.lookup idx ssMutVars - NS_TVar -> emitEdge $ IntMap.lookup idx ssTVars - NS_MVar -> emitEdge $ IntMap.lookup idx ssMVars - NS_SmallArray -> emitEdge $ IntMap.lookup idx ssSmallArrays - NS_SmallMutableArray -> emitEdge $ IntMap.lookup idx ssSmallMutableArrays + NS_Array -> emitEdge $ IntMap.lookup idx ssArrays + NS_ArrayArray -> emitEdge $ IntMap.lookup idx ssArrayArrays + NS_HeapPtr -> emitEdge $ IntMap.lookup idx ssHeap + NS_MutableArray -> emitEdge $ IntMap.lookup idx ssMutableArrays + NS_MutableArrayArray -> emitEdge $ IntMap.lookup idx ssMutableArrayArrays + NS_MutableByteArray -> pure () -- IntMap.lookup idx ssMutableByteArrays + NS_MutVar -> emitEdge $ IntMap.lookup idx ssMutVars + NS_TVar -> emitEdge $ IntMap.lookup idx ssTVars + NS_MVar -> emitEdge $ IntMap.lookup idx ssMVars + NS_SmallArray -> emitEdge $ IntMap.lookup idx ssSmallArrays + NS_SmallMutableArray -> emitEdge $ IntMap.lookup idx ssSmallMutableArrays {- NS_StableName | Just obj <- IntMap.lookup idx -- TODO -} - NS_StablePointer -> emitEdge $ IntMap.lookup idx ssStablePointers - NS_WeakPointer -> emitEdge $ IntMap.lookup idx ssWeakPointers - NS_Thread -> emitEdge $ IntMap.lookup idx ssThreads + NS_StablePointer -> emitEdge $ IntMap.lookup idx ssStablePointers + NS_WeakPointer -> emitEdge $ IntMap.lookup idx ssWeakPointers + NS_Thread -> emitEdge $ IntMap.lookup idx ssThreads - _ -> error $ "unknown StgState item: " ++ show (ns, idx) + _ -> error $ "unknown StgState item: " ++ show (ns, idx) getHeapObjectSummary :: HeapObject -> String getHeapObjectSummary = \case diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs index d835630..ebab054 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs @@ -1,23 +1,35 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} module Stg.Interpreter.Debugger.UI where -import System.Exit -import System.Posix.Process -import Control.Concurrent -import Control.Concurrent.MVar -import Control.Monad -import qualified Data.ByteString.Char8 as BS8 +import Control.Applicative (Applicative (..), (<$>)) +import Control.Concurrent (forkIO, putMVar, takeMVar) import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi -import qualified Data.List as List -import qualified Data.Map as Map -import Text.Printf -import Text.Read -import Data.Maybe - -import Stg.Interpreter.Base -import Stg.Interpreter -import Stg.Syntax -import Stg.IRLocation +import Control.Monad (Functor (..), Monad (..), forM_, mapM_, void) + +import Data.Bool (Bool (..), otherwise) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (Char) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.List (length, maximum, sum, (++)) +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import Data.String (String, lines, unlines, words) + +import Stg.Interpreter (loadAndRunProgram) +import Stg.Interpreter.Base (DebugCommand (..), DebugEvent (..), DebugOutput (..), + DebugSettings, DebugState (..), DebuggerChan (..), Env, + HeapObject (..), reportThreadIO) +import Stg.Syntax (Binder (..), BinderId (..), DC (..), DataCon (..), Id (..), + RealSrcSpan (..), SrcSpan (..), getModuleName) + +import System.Exit (ExitCode (..)) +import System.IO (IO, getLine, print, putStrLn, readFile) +import System.Posix.Process (exitImmediately) + +import Text.Printf (printf) +import Text.Read (read) +import Text.Show (Show (..)) ppSrcSpan :: SrcSpan -> String ppSrcSpan = \case @@ -33,11 +45,10 @@ debugProgram switchCWD appPath appArgs dbgChan dbgScript debugSettings = do case dbgScript of Just fname -> do dbgScriptLines <- lines <$> readFile fname - forkIO $ do + void $ forkIO $ do runDebugScript dbgChan dbgScriptLines -- HINT: start REPL when the script is finished startDebuggerReplUI dbgChan - pure () Nothing -> do -- start debug REPL UI @@ -54,25 +65,23 @@ startDebuggerReplUI dbgChan@DebuggerChan{..} = do printHelp putMVar dbgSyncRequest (CmdInternal "?") -- HINT: print internal debug commands at start - forkIO $ do + void $ forkIO $ do printDebugOutputLoop dbgChan - forkIO $ do + void $ forkIO $ do debugger dbgChan - pure () - printEnv :: Env -> IO () printEnv env = do let unBinderId (BinderId u) = u - l = maximum . map (\(Id Binder{..}) -> sum [BS8.length $ getModuleName binderModule, 2, BS8.length binderName, 1, length $ show $ unBinderId binderId]) $ Map.keys env + l = maximum . fmap (\(Id Binder{..}) -> sum [BS8.length $ getModuleName binderModule, 2, BS8.length binderName, 1, length $ show $ unBinderId binderId]) $ Map.keys env - showItem (n@(Id Binder{..}), v) = printf (" %-" ++ show l ++ "s = %s") (mod ++ " " ++ name) (show v) + showItem (Id Binder{..}, v) = printf (" %-" ++ show l ++ "s = %s") (mod' ++ " " ++ name) (show v) where BinderId u = binderId name = BS8.unpack binderName ++ ('_' : show u) - mod = BS8.unpack $ getModuleName binderModule - str = List.sort $ map showItem $ Map.toList env + mod' = BS8.unpack $ getModuleName binderModule + str = List.sort (showItem <$> Map.toList env) putStrLn $ unlines str printDebugOutputLoop :: DebuggerChan -> IO () @@ -109,8 +118,8 @@ printDebugOutput = \case DbgOutByteString msg -> BS8.putStrLn msg - DbgOutStgState stgState -> do - putStrLn $ "stg state: TODO" + DbgOutStgState _stgState -> do + putStrLn "stg state: TODO" pure () DbgOut -> pure () @@ -165,22 +174,22 @@ debugger dbgChan = do debugger dbgChan parseDebugCommand :: String -> DebuggerChan -> IO () -parseDebugCommand line dbgChan@DebuggerChan{..} = do +parseDebugCommand line DebuggerChan{..} = do case words line of ["help"] -> printHelp >> putMVar dbgSyncRequest (CmdInternal "?") --["+b", name] -> putMVar dbgSyncRequest $ CmdAddBreakpoint (BkpStgPoint . SP_RhsClosureExpr $ BS8.pack name) 0 --["+b", name, fuel] -> putMVar dbgSyncRequest $ CmdAddBreakpoint (BkpStgPoint . SP_RhsClosureExpr $ BS8.pack name) (fromMaybe 0 $ readMaybe fuel) --["-b", name] -> putMVar dbgSyncRequest $ CmdRemoveBreakpoint $ BkpStgPoint . SP_RhsClosureExpr $ BS8.pack name - ["list"] -> putMVar dbgSyncRequest $ CmdListClosures - ["clear"] -> putMVar dbgSyncRequest $ CmdClearClosureList - ["step"] -> putMVar dbgSyncRequest $ CmdStep - ["s"] -> putMVar dbgSyncRequest $ CmdStep - ["continue"] -> putMVar dbgSyncRequest $ CmdContinue - ["c"] -> putMVar dbgSyncRequest $ CmdContinue - ["k"] -> putMVar dbgSyncRequest $ CmdCurrentClosure + ["list"] -> putMVar dbgSyncRequest CmdListClosures + ["clear"] -> putMVar dbgSyncRequest CmdClearClosureList + ["step"] -> putMVar dbgSyncRequest CmdStep + ["s"] -> putMVar dbgSyncRequest CmdStep + ["continue"] -> putMVar dbgSyncRequest CmdContinue + ["c"] -> putMVar dbgSyncRequest CmdContinue + ["k"] -> putMVar dbgSyncRequest CmdCurrentClosure ["e"] -> do - putMVar dbgSyncRequest $ CmdCurrentClosure - putMVar dbgSyncRequest $ CmdStep + putMVar dbgSyncRequest CmdCurrentClosure + putMVar dbgSyncRequest CmdStep ["quit"] -> exitImmediately ExitSuccess ["stop"] -> putMVar dbgSyncRequest CmdStop ["peek", addr] -> putMVar dbgSyncRequest $ CmdPeekHeap $ read addr @@ -190,7 +199,7 @@ parseDebugCommand line dbgChan@DebuggerChan{..} = do _ -> putMVar dbgSyncRequest $ CmdInternal line runDebugScript :: DebuggerChan -> [String] -> IO () -runDebugScript dbgChan@DebuggerChan{..} lines = do +runDebugScript dbgChan@DebuggerChan{..} lines' = do let waitBreakpoint = do msg <- Unagi.readChan dbgAsyncEventOut print msg @@ -198,8 +207,8 @@ runDebugScript dbgChan@DebuggerChan{..} lines = do DbgEventHitBreakpoint{} -> putMVar dbgSyncRequest $ CmdInternal "get-current-thread-state" _ -> waitBreakpoint - forM_ lines $ \cmd -> do + forM_ lines' $ \cmd -> do putStrLn cmd case words cmd of ["wait-b"] -> waitBreakpoint - _ -> parseDebugCommand cmd dbgChan + _ -> parseDebugCommand cmd dbgChan diff --git a/external-stg-interpreter/lib/Stg/Interpreter/EmulatedLibFFI.hs b/external-stg-interpreter/lib/Stg/Interpreter/EmulatedLibFFI.hs index dbc1911..c389734 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/EmulatedLibFFI.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/EmulatedLibFFI.hs @@ -1,63 +1,42 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE CPP #-} module Stg.Interpreter.EmulatedLibFFI where ----- FFI experimental -import qualified GHC.Exts as Exts -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS - -import Foreign.Storable -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import Data.Word -import Data.Int -import Data.Maybe -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import qualified Data.Primitive.ByteArray as BA ------ -import System.Exit -import System.IO -import System.FilePath -import Text.Printf - -import Data.Time.Clock - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -import GHC.Stack -import Control.Monad.State.Strict -import Control.Concurrent.MVar - -import Stg.Syntax -import Stg.Interpreter.Base -import Stg.Interpreter.Debug - -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad.State.Strict (MonadIO (..), gets) + +import qualified Data.ByteString as BS +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.List (filter, (++)) +import Data.Maybe (Maybe) +import qualified Data.Primitive.ByteArray as BA +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word (Word8) + +import Foreign.C.Types (CInt (..), CSize (..)) +import Foreign.Ptr (Ptr) + +import qualified GHC.Exts as Exts +import GHC.Stack (HasCallStack) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (CCallTarget (..), ForeignCall (..), TyCon, Type) + +import System.FilePath (takeBaseName) +import System.IO (IO, hFlush, hPutStr, hPutStrLn, stderr) +import System.Posix (CSsize (..)) + +import Text.Printf (printf) +import Text.Show (Show (..)) {-# NOINLINE evalFCallOp #-} -evalFCallOp :: EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] -evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do +evalFCallOp :: HasCallStack => EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] +evalFCallOp _evalOnNewThread fCall@ForeignCall{..} args t _tc = do --liftIO $ putStrLn $ "[evalFCallOp] " ++ show foreignCTarget ++ " " ++ show args case foreignCTarget of @@ -88,7 +67,21 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do Rts{..} <- gets ssRtsSupport liftIO $ hPutStrLn stderr $ takeBaseName rtsProgName ++ ": " ++ printf formatStr value pure [] + + -- #include c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize + -- https://pubs.opengroup.org/onlinepubs/7908799/xsh/write.html + StaticTarget _ "ghczuwrapperZC21ZCghczminternalZCGHCziInternalziSystemziPosixziInternalsZCwrite" _ _ + | [IntAtom i, PtrAtom (ByteArrayPtr _) ptr, WordAtom w, Void] <- args + -> do + let i' = toEnum i + w' = toEnum $ fromEnum w + res <- liftIO $ c_write i' ptr w' + pure [IntV $ fromEnum res] + StaticTarget _ "errorBelch2" _ _ -> stgErrorM $ "unsupported StgFCallOp: " ++ show fCall ++ " :: " ++ show t ++ "\n args: " ++ show args _ -> stgErrorM $ "unsupported emulation of user StgFCallOp: " ++ show fCall ++ " :: " ++ show t ++ "\n args: " ++ show args + +foreign import capi unsafe "unistd.h write" + c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize diff --git a/external-stg-interpreter/lib/Stg/Interpreter/FFI.hs b/external-stg-interpreter/lib/Stg/Interpreter/FFI.hs index d38ff54..7bf3381 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/FFI.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/FFI.hs @@ -1,81 +1,64 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.FFI where ----- FFI experimental -import qualified GHC.Exts as Exts -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import Control.Concurrent - -import Foreign.Storable -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import System.Posix.DynamicLinker -import Data.Word -import Data.Int -import Data.Maybe -import qualified Foreign.LibFFI as FFI -import qualified Foreign.LibFFI.Internal as FFI -import qualified Foreign.LibFFI.FFITypes as FFI -import qualified Foreign.LibFFI.Closure as FFI -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import qualified Data.Primitive.ByteArray as BA -import qualified Data.ByteString.Char8 as BS8 ------ -import System.Exit -import System.IO -import System.FilePath -import Text.Printf - -import Data.Time.Clock - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -import GHC.Stack -import Control.Monad.State.Strict -import Control.Concurrent.MVar - -import Stg.Syntax -import Stg.GHC.Symbols -import Stg.Interpreter.Base -import Stg.Interpreter.Debug -import Stg.Interpreter.Rts (globalStoreSymbols) -import qualified Stg.Interpreter.RtsFFI as RtsFFI +import Control.Applicative (Applicative (..), (<$>)) +import Control.Concurrent (MVar, putMVar, takeMVar) +import Control.Monad (Functor (..), Monad (..), mapM, unless, zipWithM) +import Control.Monad.State.Strict (MonadIO (..), MonadState (..), StateT (..), gets, modify') + +import Data.Bool (Bool (..)) +import qualified Data.ByteString.Char8 as BS8 +import Data.Eq (Eq (..)) +import Data.Function (flip, ($), (.)) +import Data.Int (Int, Int16, Int32, Int64, Int8) +import Data.List (length, (++)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), catMaybes) +import qualified Data.Primitive.ByteArray as BA +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word (Word, Word16, Word32, Word64, Word8) + +import Foreign.C.Types (CDouble (..), CFloat (..)) +import qualified Foreign.LibFFI as FFI +import qualified Foreign.LibFFI.Closure as FFI +import qualified Foreign.LibFFI.FFITypes as FFI +import qualified Foreign.LibFFI.Internal as FFI +import Foreign.Marshal.Array (peekArray) +import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, castPtr, castPtrToFunPtr, nullFunPtr, + nullPtr) +import Foreign.Storable (Storable (..)) + +import GHC.Err (error) +import GHC.Real (fromIntegral) +import GHC.Stack (HasCallStack) + +import Stg.GHC.Symbols (Symbol (..), rtsSymbols) +import Stg.Interpreter.Base import qualified Stg.Interpreter.EmulatedLibFFI as EmulatedLibFFI +import Stg.Interpreter.Rts (globalStoreSymbols) +import qualified Stg.Interpreter.RtsFFI as RtsFFI +import Stg.Syntax (CCallTarget (..), DC (..), DataCon, ForeignCall (..), + ForeignStubs' (..), LabelSpec, Lit (..), Module, Module' (..), Name, + PrimRep (..), StubDecl' (..), StubImpl (..), TyCon, Type (..)) -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import System.IO (IO) +import System.Posix.DynamicLinker (c_dlsym, packDL) + +import Text.Show (Show (..)) emulatedLibrarySymbolSet :: Set Name emulatedLibrarySymbolSet = Set.fromList [ "errorBelch2" , "debugBelch2" + , "ghczuwrapperZC21ZCghczminternalZCGHCziInternalziSystemziPosixziInternalsZCwrite" ] rtsSymbolSet :: Set Name -rtsSymbolSet = Set.fromList $ map (BS8.pack . getSymbolName) rtsSymbols +rtsSymbolSet = Set.fromList $ fmap (BS8.pack . getSymbolName) rtsSymbols -getFFISymbol :: Name -> M (FunPtr a) +getFFISymbol :: HasCallStack => Name -> M (FunPtr a) getFFISymbol name | Set.member name rtsSymbolSet = case name of @@ -94,27 +77,27 @@ getFFISymbol name = do then stgErrorM $ "this RTS symbol is not implemented yet: " ++ BS8.unpack name else stgErrorM $ "unknown foreign symbol: " ++ BS8.unpack name -getFFILabelPtrAtom :: Name -> LabelSpec -> M Atom +getFFILabelPtrAtom :: HasCallStack => Name -> LabelSpec -> M Atom getFFILabelPtrAtom labelName labelSpec = do funPtr <- getFFISymbol labelName pure $ PtrAtom (LabelPtr labelName labelSpec) $ castFunPtrToPtr funPtr -mkFFIArg :: Atom -> M (Maybe FFI.Arg) +mkFFIArg :: HasCallStack => Atom -> M (Maybe FFI.Arg) mkFFIArg = \case - Void -> pure Nothing - PtrAtom _ p -> pure . Just $ FFI.argPtr p - IntV i -> pure . Just $ FFI.argInt64 $ fromIntegral i - Int8V i -> pure . Just $ FFI.argInt8 $ fromIntegral i - Int16V i -> pure . Just $ FFI.argInt16 $ fromIntegral i - Int32V i -> pure . Just $ FFI.argInt32 $ fromIntegral i - Int64V i -> pure . Just $ FFI.argInt64 $ fromIntegral i - WordV w -> pure . Just $ FFI.argWord64 $ fromIntegral w - Word8V w -> pure . Just $ FFI.argWord8 $ fromIntegral w - Word16V w -> pure . Just $ FFI.argWord16 $ fromIntegral w - Word32V w -> pure . Just $ FFI.argWord32 $ fromIntegral w - Word64V w -> pure . Just $ FFI.argWord64 $ fromIntegral w - FloatAtom f -> pure . Just . FFI.argCFloat $ CFloat f - DoubleAtom d -> pure . Just . FFI.argCDouble $ CDouble d + Void -> pure Nothing + PtrAtom _ p -> pure . Just $ FFI.argPtr p + IntV i -> pure . Just $ FFI.argInt64 $ fromIntegral i + Int8V i -> pure . Just $ FFI.argInt8 $ fromIntegral i + Int16V i -> pure . Just $ FFI.argInt16 $ fromIntegral i + Int32V i -> pure . Just $ FFI.argInt32 $ fromIntegral i + Int64V i -> pure . Just $ FFI.argInt64 $ fromIntegral i + WordV w -> pure . Just $ FFI.argWord64 $ fromIntegral w + Word8V w -> pure . Just $ FFI.argWord8 $ fromIntegral w + Word16V w -> pure . Just $ FFI.argWord16 $ fromIntegral w + Word32V w -> pure . Just $ FFI.argWord32 $ fromIntegral w + Word64V w -> pure . Just $ FFI.argWord64 $ fromIntegral w + FloatAtom f -> pure . Just . FFI.argCFloat $ CFloat f + DoubleAtom d -> pure . Just . FFI.argCDouble $ CDouble d ByteArray bai -> do ba <- baaMutableByteArray <$> lookupByteArrayDescriptorI bai pure . Just . FFI.argPtr $ BA.mutableByteArrayContents ba @@ -125,14 +108,14 @@ mkFFIArg = \case a -> error $ "mkFFIArg - unsupported atom: " ++ show a -evalForeignCall :: FunPtr a -> [FFI.Arg] -> Type -> IO [Atom] +evalForeignCall :: HasCallStack => FunPtr a -> [FFI.Arg] -> Type -> IO [Atom] evalForeignCall funPtr cArgs retType = do --BS8.putStrLn "[FFI.callFFI - start]" result <- evalForeignCall0 funPtr cArgs retType --BS8.putStrLn "[FFI.callFFI - end]" pure result -evalForeignCall0 :: FunPtr a -> [FFI.Arg] -> Type -> IO [Atom] +evalForeignCall0 :: HasCallStack => FunPtr a -> [FFI.Arg] -> Type -> IO [Atom] evalForeignCall0 funPtr cArgs retType = case retType of UnboxedTuple [] -> do _result <- FFI.callFFI funPtr FFI.retVoid cArgs @@ -193,7 +176,7 @@ evalForeignCall0 funPtr cArgs retType = case retType of _ -> error $ "unsupported retType: " ++ show retType {-# NOINLINE evalFCallOp #-} -evalFCallOp :: EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] +evalFCallOp :: HasCallStack => EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t tc = do --liftIO $ putStrLn $ "[evalFCallOp] " ++ show foreignCTarget ++ " " ++ show args case foreignCTarget of @@ -226,9 +209,9 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t tc = do -> do --promptM $ putStrLn $ "[global store FFI] " ++ show foreignSymbol -- HINT: set once with the first value, then return it always, only for the globalStoreSymbols - store <- gets $ rtsGlobalStore . ssRtsSupport - case Map.lookup foreignSymbol store of - Nothing -> state $ \s@StgState{..} -> ([value], s {ssRtsSupport = ssRtsSupport {rtsGlobalStore = Map.insert foreignSymbol value store}}) + store' <- gets $ rtsGlobalStore . ssRtsSupport + case Map.lookup foreignSymbol store' of + Nothing -> state $ \s@StgState{..} -> ([value], s {ssRtsSupport = ssRtsSupport {rtsGlobalStore = Map.insert foreignSymbol value store'}}) Just v -> pure [v] -- calls to GHC RTS @@ -250,9 +233,7 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t tc = do -------------- StaticTarget _ foreignSymbol _ _ -> do - let blacklist = - [ "__gmpn" - ] + -- let blacklist = [ "__gmpn" ] {- unless (any (`BS8.isPrefixOf` foreignSymbol) blacklist) $ do liftIO $ do @@ -282,13 +263,13 @@ createAdjustor :: HasCallStack => EvalOnNewThread -> Atom -> (Bool, Name, [Name] createAdjustor evalOnNewThread fun cwrapperDesc@(_, retTy, argTys) = do --liftIO $ putStrLn $ "created adjustor: " ++ show fun ++ " " ++ show cwrapperDesc - let (retCType : argsCType) = map (ffiRepToCType . ffiTypeToFFIRep) $ retTy : argTys + let (retCType :| argsCType) = fmap (ffiRepToCType . ffiTypeToFFIRep) $ retTy :| argTys stateStore <- gets $ unPrintableMVar . ssStateStore liftIO $ FFI.wrapper retCType argsCType (ffiCallbackBridge evalOnNewThread stateStore fun cwrapperDesc) {-# NOINLINE ffiCallbackBridge #-} ffiCallbackBridge :: HasCallStack => EvalOnNewThread -> MVar StgState -> Atom -> CWrapperDesc -> Ptr FFI.CIF -> Ptr FFI.CValue -> Ptr (Ptr FFI.CValue) -> Ptr Word8 -> IO () -ffiCallbackBridge evalOnNewThread stateStore fun wd@(isIOCall, retTypeName, argTypeNames) _cif retStorage argsStoragePtr _userData = do +ffiCallbackBridge evalOnNewThread stateStore fun (isIOCall, retTypeName, argTypeNames) _cif retStorage argsStoragePtr _userData = do -- read args from ffi argsStorage <- peekArray (length argTypeNames) argsStoragePtr argAtoms <- zipWithM (ffiRepToGetter . ffiTypeToFFIRep) argTypeNames argsStorage @@ -303,7 +284,7 @@ ffiCallbackBridge evalOnNewThread stateStore fun wd@(isIOCall, retTypeName, argT -} before <- takeMVar stateStore (unboxedResult, after) <- flip runStateT before $ do - funStr <- debugPrintHeapObject <$> readHeap fun + _funStr <- debugPrintHeapObject <$> readHeap fun --liftIO $ putStrLn $ " ** fun str ** = " ++ funStr {- @@ -314,7 +295,7 @@ ffiCallbackBridge evalOnNewThread stateStore fun wd@(isIOCall, retTypeName, argT scheduleToTheEnd tidFFI switchToThread tidFFI -} - fuel <- gets ssDebugFuel + _fuel <- gets ssDebugFuel --liftIO $ putStrLn $ "[step 1] fuel = " ++ show fuel boxedResult <- evalOnNewThread $ do -- TODO: box FFI arg atoms @@ -329,7 +310,7 @@ ffiCallbackBridge evalOnNewThread stateStore fun wd@(isIOCall, retTypeName, argT stackPush $ RunScheduler SR_ThreadFinishedFFICallback -- return from callback stackPush $ Apply [] -- force result to WHNF ; is this needed? --liftIO $ putStrLn $ "[step 4]" - stackPush $ Apply $ boxedArgs ++ if isIOCall then [Void] else [] + stackPush $ Apply $ boxedArgs ++ [Void | isIOCall] --liftIO $ putStrLn $ "[step 5]" --modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep} pure [fun] @@ -359,6 +340,7 @@ ffiCallbackBridge evalOnNewThread stateStore fun wd@(isIOCall, retTypeName, argT -- write result to ffi -- NOTE: only single result is supported ffiRepToSetter (ffiTypeToFFIRep retTypeName) retStorage retAtom retTypeName + (_:_) -> error "only single result is supported" -- NOTE: LiftedRep and UnliftedRep is not used in FFIRep only AddrRep newtype FFIRep = FFIRep {unFFIRep :: PrimRep} @@ -422,48 +404,48 @@ ffiRepToCType (FFIRep r) = case r of ffiRepToGetter :: FFIRep -> Ptr FFI.CValue -> IO Atom ffiRepToGetter (FFIRep r) p = case r of - VoidRep -> pure Void - Int64Rep -> Int64V . fromIntegral <$> peek (castPtr p :: Ptr Int64) - Int32Rep -> Int32V . fromIntegral <$> peek (castPtr p :: Ptr Int32) - Int16Rep -> Int16V . fromIntegral <$> peek (castPtr p :: Ptr Int16) - Int8Rep -> Int8V . fromIntegral <$> peek (castPtr p :: Ptr Int8) - IntRep -> IntV . fromIntegral <$> peek (castPtr p :: Ptr Int) - Word64Rep -> Word64V . fromIntegral <$> peek (castPtr p :: Ptr Word64) - Word32Rep -> Word32V . fromIntegral <$> peek (castPtr p :: Ptr Word32) - Word16Rep -> Word16V . fromIntegral <$> peek (castPtr p :: Ptr Word16) - Word8Rep -> Word8V . fromIntegral <$> peek (castPtr p :: Ptr Word8) - WordRep -> WordV . fromIntegral <$> peek (castPtr p :: Ptr Word) - AddrRep -> PtrAtom RawPtr <$> peek (castPtr p) - FloatRep -> FloatAtom <$> peek (castPtr p) - DoubleRep -> DoubleAtom <$> peek (castPtr p) - rep -> error $ "ffiRepToGetter - unsupported: " ++ show rep + VoidRep -> pure Void + Int64Rep -> Int64V . fromIntegral <$> peek (castPtr p :: Ptr Int64) + Int32Rep -> Int32V . fromIntegral <$> peek (castPtr p :: Ptr Int32) + Int16Rep -> Int16V . fromIntegral <$> peek (castPtr p :: Ptr Int16) + Int8Rep -> Int8V . fromIntegral <$> peek (castPtr p :: Ptr Int8) + IntRep -> IntV <$> peek (castPtr p :: Ptr Int) + Word64Rep -> Word64V . fromIntegral <$> peek (castPtr p :: Ptr Word64) + Word32Rep -> Word32V . fromIntegral <$> peek (castPtr p :: Ptr Word32) + Word16Rep -> Word16V . fromIntegral <$> peek (castPtr p :: Ptr Word16) + Word8Rep -> Word8V . fromIntegral <$> peek (castPtr p :: Ptr Word8) + WordRep -> WordV <$> peek (castPtr p :: Ptr Word) + AddrRep -> PtrAtom RawPtr <$> peek (castPtr p) + FloatRep -> FloatAtom <$> peek (castPtr p) + DoubleRep -> DoubleAtom <$> peek (castPtr p) + rep -> error $ "ffiRepToGetter - unsupported: " ++ show rep ffiRepToSetter :: FFIRep -> Ptr FFI.CValue -> Atom -> Name -> IO () ffiRepToSetter (FFIRep r) p a retTypeName = case (r, a) of - (VoidRep, Void) -> pure () - (FloatRep, FloatAtom v) -> poke (castPtr p) v - (DoubleRep, DoubleAtom v) -> poke (castPtr p) v - (Int64Rep, Int64V v) -> poke (castPtr p :: Ptr Int64) $ fromIntegral v - (Int32Rep, Int32V v) -> poke (castPtr p :: Ptr Int32) $ fromIntegral v - (Int16Rep, Int16V v) -> poke (castPtr p :: Ptr Int16) $ fromIntegral v - (Int8Rep, Int8V v) -> poke (castPtr p :: Ptr Int8) $ fromIntegral v - (IntRep, IntV v) -> poke (castPtr p :: Ptr Int) $ fromIntegral v - (Word64Rep, Word64V v) -> poke (castPtr p :: Ptr Word64) $ fromIntegral v - (Word32Rep, Word32V v) -> poke (castPtr p :: Ptr Word32) $ fromIntegral v - (Word16Rep, Word16V v) -> poke (castPtr p :: Ptr Word16) $ fromIntegral v - (Word8Rep, Word8V v) -> poke (castPtr p :: Ptr Word8) $ fromIntegral v - (WordRep, WordV v) -> poke (castPtr p :: Ptr Word) $ fromIntegral v - (AddrRep, PtrAtom RawPtr v) -> poke (castPtr p) v - x -> error $ "ffiRepToSetter - unsupported: " ++ show (x, retTypeName) + (VoidRep, Void) -> pure () + (FloatRep, FloatAtom v) -> poke (castPtr p) v + (DoubleRep, DoubleAtom v) -> poke (castPtr p) v + (Int64Rep, Int64V v) -> poke (castPtr p :: Ptr Int64) $ fromIntegral v + (Int32Rep, Int32V v) -> poke (castPtr p :: Ptr Int32) $ fromIntegral v + (Int16Rep, Int16V v) -> poke (castPtr p :: Ptr Int16) $ fromIntegral v + (Int8Rep, Int8V v) -> poke (castPtr p :: Ptr Int8) $ fromIntegral v + (IntRep, IntV v) -> poke (castPtr p :: Ptr Int) $ v + (Word64Rep, Word64V v) -> poke (castPtr p :: Ptr Word64) $ fromIntegral v + (Word32Rep, Word32V v) -> poke (castPtr p :: Ptr Word32) $ fromIntegral v + (Word16Rep, Word16V v) -> poke (castPtr p :: Ptr Word16) $ fromIntegral v + (Word8Rep, Word8V v) -> poke (castPtr p :: Ptr Word8) $ fromIntegral v + (WordRep, WordV v) -> poke (castPtr p :: Ptr Word) $ v + (AddrRep, PtrAtom RawPtr v) -> poke (castPtr p) v + x -> error $ "ffiRepToSetter - unsupported: " ++ show (x, retTypeName) unboxFFIAtom :: HasCallStack => Name -> Atom -> M Atom unboxFFIAtom hsFFIType a = case (hsFFIType, a) of - ("()", HeapPtr{}) -> pure Void - ("Int", HeapPtr{}) -> con1Unbox - ("Int32", HeapPtr{}) -> con1Unbox - ("Double", HeapPtr{}) -> con1Unbox + ("()", HeapPtr{}) -> pure Void + ("Int", HeapPtr{}) -> con1Unbox + ("Int32", HeapPtr{}) -> con1Unbox + ("Double", HeapPtr{}) -> con1Unbox -- TODO: make this complete - x -> error $ "unboxFFIAtom - unknown pattern: " ++ show x + x -> error $ "unboxFFIAtom - unknown pattern: " ++ show x where con1Unbox = do readHeap a >>= \case @@ -473,21 +455,21 @@ unboxFFIAtom hsFFIType a = case (hsFFIType, a) of boxFFIAtom :: Name -> Atom -> M Atom boxFFIAtom hsFFIType a = case (hsFFIType, a) of -- boxed Char - ("Char", WordV _) -> mkWiredInCon rtsCharCon [a] + ("Char", WordV _) -> mkWiredInCon rtsCharCon [a] -- boxed Ints - ("Int", IntV _) -> mkWiredInCon rtsIntCon [a] - ("Int8", Int8V _) -> mkWiredInCon rtsInt8Con [a] - ("Int16", Int16V _) -> mkWiredInCon rtsInt16Con [a] - ("Int32", Int32V _) -> mkWiredInCon rtsInt32Con [a] - ("Int64", Int64V _) -> mkWiredInCon rtsInt64Con [a] + ("Int", IntV _) -> mkWiredInCon rtsIntCon [a] + ("Int8", Int8V _) -> mkWiredInCon rtsInt8Con [a] + ("Int16", Int16V _) -> mkWiredInCon rtsInt16Con [a] + ("Int32", Int32V _) -> mkWiredInCon rtsInt32Con [a] + ("Int64", Int64V _) -> mkWiredInCon rtsInt64Con [a] -- boxed Words - ("Word", WordV _) -> mkWiredInCon rtsWordCon [a] - ("Word8", Word8V _) -> mkWiredInCon rtsWord8Con [a] - ("Word16", Word16V _) -> mkWiredInCon rtsWord16Con [a] - ("Word32", Word32V _) -> mkWiredInCon rtsWord32Con [a] - ("Word64", Word64V _) -> mkWiredInCon rtsWord64Con [a] + ("Word", WordV _) -> mkWiredInCon rtsWordCon [a] + ("Word8", Word8V _) -> mkWiredInCon rtsWord8Con [a] + ("Word16", Word16V _) -> mkWiredInCon rtsWord16Con [a] + ("Word32", Word32V _) -> mkWiredInCon rtsWord32Con [a] + ("Word64", Word64V _) -> mkWiredInCon rtsWord64Con [a] ("Ptr", PtrAtom RawPtr _) -> mkWiredInCon rtsPtrCon [a] ("FunPtr", PtrAtom RawPtr _) -> mkWiredInCon rtsFunPtrCon [a] @@ -499,7 +481,7 @@ boxFFIAtom hsFFIType a = case (hsFFIType, a) of ("Bool", IntV i) -> mkWiredInCon (if i == 0 then rtsFalseCon else rtsTrueCon) [] ("String", PtrAtom RawPtr _) -> error "TODO: support C string FFI arg boxing" - x -> error $ "boxFFIAtom - unknown pattern: " ++ show x + x -> error $ "boxFFIAtom - unknown pattern: " ++ show x mkWiredInCon :: (Rts -> DataCon) -> [Atom] -> M Atom mkWiredInCon conFun args = do @@ -518,12 +500,12 @@ buildCWrapperHsTypeMap :: [Module] -> M () buildCWrapperHsTypeMap mods = do let m = Map.fromListWithKey (\k a b -> error $ "CWrapper name duplication: " ++ show k ++ " with hsTypes: " ++ show (a, b)) [ (name, (isIOCall, retType, argTypes)) - | ForeignStubs{..} <- map moduleForeignStubs mods + | ForeignStubs{..} <- fmap moduleForeignStubs mods , StubDeclImport _ (Just (StubImplImportCWrapper name _ isIOCall retType argTypes)) <- fsDecls ] - modify' $ \s@StgState{..} -> s {ssCWrapperHsTypeMap = m} + modify' $ \s -> s {ssCWrapperHsTypeMap = m} {- liftIO $ do putStrLn $ "CWrappers:" forM_ (Map.toList m) $ \(k, v) -> print k >> print v - -} \ No newline at end of file + -} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/GC.hs b/external-stg-interpreter/lib/Stg/Interpreter/GC.hs index aa6d0b7..e8efbc8 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/GC.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/GC.hs @@ -1,26 +1,43 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, FlexibleInstances #-} -module Stg.Interpreter.GC where - -import Text.Printf -import Control.Monad.State -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - -import Control.Concurrent -import Stg.Syntax -import Stg.Interpreter.Debug (exportCallGraph) -import Stg.Interpreter.Base -import Stg.Interpreter.GC.LiveDataAnalysis -import Stg.Interpreter.GC.DeadlockAnalysis -import qualified Stg.Interpreter.PrimOp.WeakPointer as PrimWeakPointer - -import Stg.Interpreter.GC.RetainerAnalysis +module Stg.Interpreter.GC where -import Data.Time.Clock +import Control.Applicative (Applicative (..)) +import Control.Concurrent (MVar, ThreadId, forkIO, newEmptyMVar, putMVar, takeMVar, + tryTakeMVar) +import Control.Monad (Monad (..), mapM, mapM_, unless, when) +import Control.Monad.State (MonadIO (..), MonadState (..), gets, modify') + +import Data.Bool (Bool (..), not, (&&), (||)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List (length, null, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import Data.Ord (Ord (..)) +import Data.String (String) +import Data.Time.Clock (getCurrentTime) + +import GHC.Float (Float) +import GHC.Num (Num (..)) +import GHC.Real (Fractional (..), fromIntegral) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base (Atom, HeapObject (..), M, PrintableMVar (..), RefSet (..), + StgState (..), ThreadState (..), getAddressState, isThreadLive, + lookupWeakPointerDescriptor, mylog, promptM_) +import Stg.Interpreter.Debug (exportCallGraph) +import Stg.Interpreter.GC.DeadlockAnalysis (handleDeadlockedThreads, validateGCThreadResult) +import Stg.Interpreter.GC.LiveDataAnalysis (runLiveDataAnalysis) +import Stg.Interpreter.GC.RetainerAnalysis (loadRetainerDb) + +import System.IO (IO, print, putStrLn) + +import Text.Printf (printf) +import Text.Show (Show (..)) checkGC :: [Atom] -> M () checkGC localGCRoots = do @@ -29,7 +46,7 @@ checkGC localGCRoots = do lastGCAddr <- gets ssLastGCAddr gcIsRunning <- gets ssGCIsRunning - lastGCTime <- gets ssLastGCTime + _lastGCTime <- gets ssLastGCTime t0 <- liftIO getCurrentTime requestMajorGC <- gets ssRequestMajorGC let @@ -48,8 +65,8 @@ checkGC localGCRoots = do , ssRequestMajorGC = False } runGC localGCRoots - t0 <- liftIO getCurrentTime - modify' $ \s@StgState{..} -> s {ssLastGCTime = t0} + _t0 <- liftIO getCurrentTime + modify' $ \s -> s {ssLastGCTime = t0} {- TODO: done - send the current state for live data analysis (async channel) if the GC condition triggers @@ -157,7 +174,7 @@ reportDeletedCode old = do finalizeDeadWeakPointers :: IntSet -> M () finalizeDeadWeakPointers rsWeaks = do let deadWeaks = IntSet.toList rsWeaks - wdescs <- mapM lookupWeakPointerDescriptor deadWeaks + _wdescs <- mapM lookupWeakPointerDescriptor deadWeaks {- liftIO $ do putStrLn $ " * GC - run finalizers for dead weak pointers: " ++ show rsWeaks @@ -221,20 +238,20 @@ reportAddressCounters StgState{..} = do let reportI msg val = do printf " %s %d\n" msg val putStrLn "resource address counters:" - reportI "ssNextHeapAddr " ssNextHeapAddr - reportI "ssNextStableName " ssNextStableName - reportI "ssNextWeakPointer " ssNextWeakPointer - reportI "ssNextStablePointer " ssNextStablePointer - reportI "ssNextMutableByteArray " ssNextMutableByteArray - reportI "ssNextMVar " ssNextMVar - reportI "ssNextTVar " ssNextTVar - reportI "ssNextMutVar " ssNextMutVar - reportI "ssNextArray " ssNextArray - reportI "ssNextMutableArray " ssNextMutableArray - reportI "ssNextSmallArray " ssNextSmallArray - reportI "ssNextSmallMutableArray " ssNextSmallMutableArray - reportI "ssNextArrayArray " ssNextArrayArray - reportI "ssNextMutableArrayArray " ssNextMutableArrayArray + reportI ("ssNextHeapAddr " :: String) ssNextHeapAddr + reportI ("ssNextStableName " :: String) ssNextStableName + reportI ("ssNextWeakPointer " :: String) ssNextWeakPointer + reportI ("ssNextStablePointer " :: String) ssNextStablePointer + reportI ("ssNextMutableByteArray " :: String) ssNextMutableByteArray + reportI ("ssNextMVar " :: String) ssNextMVar + reportI ("ssNextTVar " :: String) ssNextTVar + reportI ("ssNextMutVar " :: String) ssNextMutVar + reportI ("ssNextArray " :: String) ssNextArray + reportI ("ssNextMutableArray " :: String) ssNextMutableArray + reportI ("ssNextSmallArray " :: String) ssNextSmallArray + reportI ("ssNextSmallMutableArray " :: String) ssNextSmallMutableArray + reportI ("ssNextArrayArray " :: String) ssNextArrayArray + reportI ("ssNextMutableArrayArray " :: String) ssNextMutableArrayArray reportRemovedData :: StgState -> RefSet -> IO () reportRemovedData StgState{..} RefSet{..} = do @@ -250,19 +267,19 @@ reportRemovedData StgState{..} RefSet{..} = do putStrLn "freed after GC:" - reportI "ssHeap " ssHeap rsHeap - reportI "ssWeakPointers " ssWeakPointers rsWeakPointers - reportI "ssTVars " ssTVars rsTVars - reportI "ssMVars " ssMVars rsMVars - reportI "ssMutVars " ssMutVars rsMutVars - reportI "ssArrays " ssArrays rsArrays - reportI "ssMutableArrays " ssMutableArrays rsMutableArrays - reportI "ssSmallArrays " ssSmallArrays rsSmallArrays - reportI "ssSmallMutableArrays " ssSmallMutableArrays rsSmallMutableArrays - reportI "ssArrayArrays " ssArrayArrays rsArrayArrays - reportI "ssMutableArrayArrays " ssMutableArrayArrays rsMutableArrayArrays - reportI "ssMutableByteArrays " ssMutableByteArrays rsMutableByteArrays - reportM "ssStableNameMap " ssStableNameMap rsStableNames + reportI ("ssHeap " :: String) ssHeap rsHeap + reportI ("ssWeakPointers " :: String) ssWeakPointers rsWeakPointers + reportI ("ssTVars " :: String) ssTVars rsTVars + reportI ("ssMVars " :: String) ssMVars rsMVars + reportI ("ssMutVars " :: String) ssMutVars rsMutVars + reportI ("ssArrays " :: String) ssArrays rsArrays + reportI ("ssMutableArrays " :: String) ssMutableArrays rsMutableArrays + reportI ("ssSmallArrays " :: String) ssSmallArrays rsSmallArrays + reportI ("ssSmallMutableArrays " :: String) ssSmallMutableArrays rsSmallMutableArrays + reportI ("ssArrayArrays " :: String) ssArrayArrays rsArrayArrays + reportI ("ssMutableArrayArrays " :: String) ssMutableArrayArrays rsMutableArrayArrays + reportI ("ssMutableByteArrays " :: String) ssMutableByteArrays rsMutableByteArrays + reportM ("ssStableNameMap " :: String) ssStableNameMap rsStableNames let threads = IntMap.elems ssThreads printf "live threads: %-6d all threads: %d\n" (length $ [ts | ts <- threads, isThreadLive (tsStatus ts)]) (length threads) diff --git a/external-stg-interpreter/lib/Stg/Interpreter/GC/DeadlockAnalysis.hs b/external-stg-interpreter/lib/Stg/Interpreter/GC/DeadlockAnalysis.hs index 24765b8..ea726f0 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/GC/DeadlockAnalysis.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/GC/DeadlockAnalysis.hs @@ -1,15 +1,25 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} module Stg.Interpreter.GC.DeadlockAnalysis where -import Control.Monad -import Control.Monad.State -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import qualified Data.IntMap as IntMap +import Control.Applicative (Applicative (..)) +import Control.Monad (forM_, when) +import Control.Monad.State (MonadState (..), gets) -import Stg.Interpreter.Base +import Data.Bool ((&&)) +import Data.Function (($)) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List (reverse, (++)) +import Data.Maybe (Maybe (..)) + +import GHC.Err (error) + +import Stg.Interpreter.Base (BlockReason (..), M, RefSet (..), Rts (..), StgState (..), + ThreadState (..), ThreadStatus (..), getThreadState, reportThread) import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency +import Text.Show (Show (..)) + validateGCThreadResult :: RefSet -> IntSet -> M () validateGCThreadResult RefSet{..} deadlockedThreadIds = do @@ -36,7 +46,6 @@ validateGCThreadResult RefSet{..} deadlockedThreadIds = do BlockedOnRead{} -> assertLiveThread tid BlockedOnWrite{} -> assertLiveThread tid BlockedOnDelay{} -> assertLiveThread tid - pure () -- the analysis is done in datalog, this code just uses the analysis result @@ -63,5 +72,5 @@ handleDeadlockedThreads deadlockedThreadIds = do BlockedOnThrowAsyncEx{} -> pure () -- HINT: it might be blocked on other deadlocked thread BlockedOnSTM{} -> raiseEx tid rtsBlockedIndefinitelyOnSTM BlockedOnForeignCall{} -> error "not implemented yet" - s -> error $ "internal error - invalid thread state: " ++ show s + s -> error $ "internal error - invalid thread state: " ++ show s s -> error $ "internal error - invalid thread state: " ++ show s diff --git a/external-stg-interpreter/lib/Stg/Interpreter/GC/GCRef.hs b/external-stg-interpreter/lib/Stg/Interpreter/GC/GCRef.hs index 7a82c58..6afcdde 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/GC/GCRef.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/GC/GCRef.hs @@ -1,13 +1,23 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, FlexibleInstances #-} module Stg.Interpreter.GC.GCRef where -import Data.Maybe -import Control.Monad -import Foreign.Ptr -import qualified Data.IntSet as IntSet +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..), forM_, mapM_) + import qualified Data.ByteString.Char8 as BS8 +import Data.Eq (Eq) +import Data.Foldable (Foldable) +import Data.Function (($), (.)) +import Data.Int (Int) +import qualified Data.IntSet as IntSet +import Data.Ord (Ord) + +import Stg.Interpreter.Base (ArrIdx (..), ArrayArrIdx (..), Atom (..), ByteArrayIdx (..), GCSymbol (..), + HeapObject (..), MVarDescriptor (..), PtrOrigin (..), SmallArrIdx (..), + StackContinuation (..), TVarDescriptor (..), ThreadState (..), + WeakPtrDescriptor (..)) -import Stg.Interpreter.Base +import Text.Read (Read, read) +import Text.Show (Show (..)) -- HINT: populate datalog database during a traversal @@ -15,20 +25,24 @@ class VisitGCRef a where visitGCRef :: Monad m => (GCSymbol -> m ()) -> a -> m () instance VisitGCRef Atom where + visitGCRef :: Monad m => (GCSymbol -> m ()) -> Atom -> m () visitGCRef action a = visitAtom a action instance (Foldable t, VisitGCRef a) => VisitGCRef (t a) where - visitGCRef action a = mapM_ (visitGCRef action) a + visitGCRef :: (Monad m) => (GCSymbol -> m ()) -> t a -> m () + visitGCRef action = mapM_ (visitGCRef action) instance VisitGCRef HeapObject where + visitGCRef :: Monad m => (GCSymbol -> m ()) -> HeapObject -> m () visitGCRef action = \case Con{..} -> visitGCRef action hoConArgs Closure{..} -> visitGCRef action hoCloArgs >> visitGCRef action hoEnv - BlackHole _ _ _ -> pure () -- HINT: the blackhole wait queue is handled separately + BlackHole {} -> pure () -- HINT: the blackhole wait queue is handled separately ApStack{..} -> visitGCRef action hoResult >> visitGCRef action hoStack RaiseException ex -> visitGCRef action ex instance VisitGCRef StackContinuation where + visitGCRef :: Monad m => (GCSymbol -> m ()) -> StackContinuation -> m () visitGCRef action = \case CaseOf _ _ env _ _ _ -> visitGCRef action env Update{} -> pure () -- HINT: the thunk is under evaluation, its closure is referred from the thread stack @@ -47,6 +61,7 @@ instance VisitGCRef StackContinuation where DebugFrame{} -> pure () instance VisitGCRef ThreadState where + visitGCRef :: Monad m => (GCSymbol -> m ()) -> ThreadState -> m () visitGCRef action ThreadState{..} = do visitGCRef action tsCurrentResult visitGCRef action tsStack @@ -82,6 +97,7 @@ instance VisitGCRef TLogEntry where -} instance VisitGCRef WeakPtrDescriptor where -- NOTE: the value is not tracked by the GC + visitGCRef :: Monad m => (GCSymbol -> m ()) -> WeakPtrDescriptor -> m () visitGCRef action WeakPtrDescriptor{..} = do ----------- temporarly track the value -- FIXME visitGCRef action wpdValue @@ -94,11 +110,13 @@ instance VisitGCRef WeakPtrDescriptor where visitGCRef action ma2 instance VisitGCRef MVarDescriptor where + visitGCRef :: Monad m => (GCSymbol -> m ()) -> MVarDescriptor -> m () visitGCRef action MVarDescriptor{..} = do visitGCRef action mvdValue forM_ mvdQueue $ \tid -> action $ encodeRef tid NS_Thread instance VisitGCRef TVarDescriptor where + visitGCRef :: Monad m => (GCSymbol -> m ()) -> TVarDescriptor -> m () visitGCRef action TVarDescriptor{..} = do visitGCRef action tvdValue forM_ (IntSet.toList tvdQueue) $ \tid -> action $ encodeRef tid NS_Thread @@ -120,7 +138,7 @@ data RefNamespace | NS_StablePointer | NS_WeakPointer | NS_Thread - deriving (Eq, Ord, Show, Read) + deriving stock (Eq, Ord, Show, Read) encodeRef :: Int -> RefNamespace -> GCSymbol encodeRef i ns = GCSymbol $ BS8.pack $ show (ns, i) @@ -130,33 +148,33 @@ decodeRef = read . BS8.unpack . unGCSymbol visitAtom :: Monad m => Atom -> (GCSymbol -> m ()) -> m () visitAtom atom action = case atom of - HeapPtr i -> action $ encodeRef i NS_HeapPtr - Literal{} -> pure () - Void -> pure () + HeapPtr i -> action $ encodeRef i NS_HeapPtr + Literal{} -> pure () + Void -> pure () PtrAtom (StablePtr i) _ -> action $ encodeRef i NS_StablePointer -- HINT: for debug purposes (track usage) keep this reference - PtrAtom{} -> pure () - IntAtom{} -> pure () - WordAtom{} -> pure () - FloatAtom{} -> pure () - DoubleAtom{} -> pure () - MVar i -> action $ encodeRef i NS_MVar - MutVar i -> action $ encodeRef i NS_MutVar - TVar i -> action $ encodeRef i NS_TVar - Array i -> action $ arrIdxToRef i - MutableArray i -> action $ arrIdxToRef i - SmallArray i -> action $ smallArrIdxToRef i - SmallMutableArray i -> action $ smallArrIdxToRef i - ArrayArray i -> action $ arrayArrIdxToRef i - MutableArrayArray i -> action $ arrayArrIdxToRef i - ByteArray i -> action $ encodeRef (baId i) NS_MutableByteArray - MutableByteArray i -> action $ encodeRef (baId i) NS_MutableByteArray - WeakPointer i -> action $ encodeRef i NS_WeakPointer - StableName i -> action $ encodeRef i NS_StableName - ThreadId i -> action $ encodeRef i NS_Thread -- NOTE: in GHC the ThreadId# prim type is a strong pointer to TSO (thread state oject) - LiftedUndefined{} -> pure () - Rubbish{} -> pure () - Unbinded{} -> pure () - _ -> error $ "internal error - incomplete pattern: " ++ show atom + PtrAtom{} -> pure () + IntAtom{} -> pure () + WordAtom{} -> pure () + FloatAtom{} -> pure () + DoubleAtom{} -> pure () + MVar i -> action $ encodeRef i NS_MVar + MutVar i -> action $ encodeRef i NS_MutVar + TVar i -> action $ encodeRef i NS_TVar + Array i -> action $ arrIdxToRef i + MutableArray i -> action $ arrIdxToRef i + SmallArray i -> action $ smallArrIdxToRef i + SmallMutableArray i -> action $ smallArrIdxToRef i + ArrayArray i -> action $ arrayArrIdxToRef i + MutableArrayArray i -> action $ arrayArrIdxToRef i + ByteArray i -> action $ encodeRef (baId i) NS_MutableByteArray + MutableByteArray i -> action $ encodeRef (baId i) NS_MutableByteArray + WeakPointer i -> action $ encodeRef i NS_WeakPointer + StableName i -> action $ encodeRef i NS_StableName + ThreadId i -> action $ encodeRef i NS_Thread -- NOTE: in GHC the ThreadId# prim type is a strong pointer to TSO (thread state oject) + LiftedUndefined{} -> pure () + Rubbish{} -> pure () + Unbinded{} -> pure () + -- _ -> error $ "internal error - incomplete pattern: " ++ show atom arrIdxToRef :: ArrIdx -> GCSymbol arrIdxToRef = \case diff --git a/external-stg-interpreter/lib/Stg/Interpreter/GC/LiveDataAnalysis.hs b/external-stg-interpreter/lib/Stg/Interpreter/GC/LiveDataAnalysis.hs index 54d6f44..5956fc2 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/GC/LiveDataAnalysis.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/GC/LiveDataAnalysis.hs @@ -1,56 +1,81 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, DeriveGeneric #-} module Stg.Interpreter.GC.LiveDataAnalysis where -import GHC.Generics -import Control.Monad.State -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Set (Set) -import qualified Data.Set as Set -import System.FilePath -import System.Directory -import Foreign.Ptr -import Text.Printf -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 - -import Language.Souffle.Compiled (SouffleM) +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Functor (..), Monad, MonadFail (..), foldM, forM_, unless) +import Control.Monad.State (MonadIO (..)) + +import Data.Bool (Bool (..)) +import qualified Data.ByteString.Char8 as BS8 +import Data.Data (Proxy) +import Data.Eq (Eq) +import Data.Function (const, ($), (.)) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List ((++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import Data.Ord (Ord (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (String) + +import Foreign.Ptr (IntPtr (..), intPtrToPtr) + +import GHC.Err (error) +import GHC.Generics (Generic) + +import Language.Souffle.Compiled (SouffleM) import qualified Language.Souffle.Compiled as Souffle -import Stg.Interpreter.Base -import Stg.Interpreter.GC.GCRef +import Stg.Interpreter.Base (Atom (..), BlockReason (..), DebugSettings (..), GCSymbol (..), + HeapObject (..), PtrOrigin (..), RefSet (..), StackContinuation (..), + StgState (..), ThreadState (..), ThreadStatus (..), emptyRefSet) +import Stg.Interpreter.GC.GCRef (RefNamespace (..), VisitGCRef (..), decodeRef, encodeRef) + +import System.Directory (createDirectoryIfMissing, makeAbsolute) +import System.FilePath (FilePath, ()) +import System.IO (IO, putStrLn) + +import Text.Printf (printf) +import Text.Show (Show (..)) -------- souffle program data ExtStgGC = ExtStgGC -data GCRoot = GCRoot String - deriving (Eq, Show, Generic) +newtype GCRoot = GCRoot String + deriving stock (Eq, Show, Generic) data Reference = Reference String String - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) data MaybeDeadlockingThread = MaybeDeadlockingThread String - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) instance Souffle.Program ExtStgGC where type ProgramFacts ExtStgGC = [GCRoot, Reference, MaybeDeadlockingThread] + + programName :: ExtStgGC -> String programName = const "ext_stg_gc" instance Souffle.Fact GCRoot where type FactDirection GCRoot = 'Souffle.Input + + factName :: Proxy GCRoot -> String factName = const "GCRoot" instance Souffle.Fact Reference where type FactDirection Reference = 'Souffle.Input + + factName :: Proxy Reference -> String factName = const "Reference" instance Souffle.Fact MaybeDeadlockingThread where type FactDirection MaybeDeadlockingThread = 'Souffle.Input + + factName :: Proxy MaybeDeadlockingThread -> String factName = const "MaybeDeadlockingThread" instance Souffle.Marshal GCRoot @@ -100,8 +125,8 @@ addGCRootFacts prog stgState localGCRoots = withGCRootFacts stgState localGCRoot Souffle.addFact prog $ GCRoot $ BS8.unpack $ unGCSymbol s addReferenceFacts :: Souffle.Handle ExtStgGC -> StgState -> SouffleM () -addReferenceFacts prog stgState = withReferenceFacts stgState $ \from to -> do - Souffle.addFact prog $ Reference (BS8.unpack $ unGCSymbol from) (BS8.unpack $ unGCSymbol to) +addReferenceFacts prog stgState = withReferenceFacts stgState $ \from' to' -> do + Souffle.addFact prog $ Reference (BS8.unpack $ unGCSymbol from') (BS8.unpack $ unGCSymbol to') withGCRootFacts :: Monad m => StgState -> [Atom] -> (String -> GCSymbol -> m ()) -> m () withGCRootFacts StgState{..} localGCRoots addGCRoot = do @@ -123,7 +148,7 @@ withGCRootFacts StgState{..} localGCRoots addGCRoot = do visitGCRef (addGCRoot "stable pointer") [PtrAtom (StablePtr idx) (intPtrToPtr $ IntPtr idx) | idx <- IntMap.keys ssStablePointers] -- CAFs - visitGCRef (addGCRoot "CAF") $ map HeapPtr $ IntSet.toList ssCAFSet + visitGCRef (addGCRoot "CAF") (HeapPtr <$> IntSet.toList ssCAFSet) -- stack continuations of live threads forM_ (IntMap.toList ssThreads) $ \(tid, ts) -> case tsStatus ts of @@ -143,7 +168,7 @@ withGCRootFacts StgState{..} localGCRoots addGCRoot = do withReferenceFacts :: forall m . Monad m => StgState -> (GCSymbol -> GCSymbol -> m ()) -> m () withReferenceFacts StgState{..} addReference = do - let addRefs :: (VisitGCRef a, Monad m) => IntMap a -> RefNamespace -> m () + let addRefs :: (VisitGCRef a) => IntMap a -> RefNamespace -> m () addRefs im ns = do let l = IntMap.toList im forM_ l $ \(i, v) -> visitGCRef (addReference (encodeRef i ns)) v @@ -151,6 +176,7 @@ withReferenceFacts StgState{..} addReference = do -- HINT: these types are tracked by GC let dynamicHeap = IntMap.filterWithKey (\a _ -> a >= ssDynamicHeapStart) ssHeap cafHeap = IntMap.restrictKeys ssHeap ssCAFSet + addRefs dynamicHeap NS_HeapPtr addRefs cafHeap NS_HeapPtr addRefs ssWeakPointers NS_WeakPointer @@ -217,36 +243,36 @@ collectGCSymbol dd@RefSet{..} sym = do -- HINT: decode datalog value let (namespace, idx) = decodeRef sym pure $ case namespace of - NS_Array -> dd {rsArrays = IntSet.insert idx rsArrays} - NS_ArrayArray -> dd {rsArrayArrays = IntSet.insert idx rsArrayArrays} - NS_HeapPtr -> dd {rsHeap = IntSet.insert idx rsHeap} - NS_MutableArray -> dd {rsMutableArrays = IntSet.insert idx rsMutableArrays} - NS_MutableArrayArray -> dd {rsMutableArrayArrays = IntSet.insert idx rsMutableArrayArrays} - NS_MutableByteArray -> dd {rsMutableByteArrays = IntSet.insert idx rsMutableByteArrays} - NS_MutVar -> dd {rsMutVars = IntSet.insert idx rsMutVars} - NS_TVar -> dd {rsTVars = IntSet.insert idx rsTVars} - NS_MVar -> dd {rsMVars = IntSet.insert idx rsMVars} - NS_SmallArray -> dd {rsSmallArrays = IntSet.insert idx rsSmallArrays} - NS_SmallMutableArray -> dd {rsSmallMutableArrays = IntSet.insert idx rsSmallMutableArrays} - NS_StableName -> dd {rsStableNames = IntSet.insert idx rsStableNames} - NS_WeakPointer -> dd {rsWeakPointers = IntSet.insert idx rsWeakPointers} - NS_StablePointer -> dd {rsStablePointers = IntSet.insert idx rsStablePointers} - NS_Thread -> dd {rsThreads = IntSet.insert idx rsThreads} - _ -> error $ "invalid dead value: " ++ show namespace ++ " " ++ show idx + NS_Array -> dd {rsArrays = IntSet.insert idx rsArrays} + NS_ArrayArray -> dd {rsArrayArrays = IntSet.insert idx rsArrayArrays} + NS_HeapPtr -> dd {rsHeap = IntSet.insert idx rsHeap} + NS_MutableArray -> dd {rsMutableArrays = IntSet.insert idx rsMutableArrays} + NS_MutableArrayArray -> dd {rsMutableArrayArrays = IntSet.insert idx rsMutableArrayArrays} + NS_MutableByteArray -> dd {rsMutableByteArrays = IntSet.insert idx rsMutableByteArrays} + NS_MutVar -> dd {rsMutVars = IntSet.insert idx rsMutVars} + NS_TVar -> dd {rsTVars = IntSet.insert idx rsTVars} + NS_MVar -> dd {rsMVars = IntSet.insert idx rsMVars} + NS_SmallArray -> dd {rsSmallArrays = IntSet.insert idx rsSmallArrays} + NS_SmallMutableArray -> dd {rsSmallMutableArrays = IntSet.insert idx rsSmallMutableArrays} + NS_StableName -> dd {rsStableNames = IntSet.insert idx rsStableNames} + NS_WeakPointer -> dd {rsWeakPointers = IntSet.insert idx rsWeakPointers} + NS_StablePointer -> dd {rsStablePointers = IntSet.insert idx rsStablePointers} + NS_Thread -> dd {rsThreads = IntSet.insert idx rsThreads} + -- _ -> error $ "invalid dead value: " ++ show namespace ++ " " ++ show idx readbackLiveData :: FilePath -> Bool -> SouffleM RefSet readbackLiveData factDir isQuiet = do liveSet <- liftIO $ loadStringSet isQuiet (factDir "Live.csv") - foldM (\dd sym -> collectGCSymbol dd sym) emptyRefSet $ Set.toList liveSet + foldM collectGCSymbol emptyRefSet $ Set.toList liveSet readbackDeadlockingThreadData :: FilePath -> Bool -> SouffleM IntSet readbackDeadlockingThreadData factDir isQuiet = do deadlockingSet <- liftIO $ loadStringSet isQuiet (factDir "DeadlockingThread.csv") - rsThreads <$> foldM (\dd sym -> collectGCSymbol dd sym) emptyRefSet (Set.toList deadlockingSet) + rsThreads <$> foldM collectGCSymbol emptyRefSet (Set.toList deadlockingSet) loadStringSet :: Bool -> String -> IO (Set GCSymbol) loadStringSet isQuiet factPath = do absFactPath <- makeAbsolute factPath unless isQuiet $ do putStrLn $ "loading: " ++ show absFactPath - Set.fromList . map GCSymbol . BS8.lines <$> BS8.readFile absFactPath + Set.fromList . fmap GCSymbol . BS8.lines <$> BS8.readFile absFactPath diff --git a/external-stg-interpreter/lib/Stg/Interpreter/GC/RetainerAnalysis.hs b/external-stg-interpreter/lib/Stg/Interpreter/GC/RetainerAnalysis.hs index e454f92..ebcfe56 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/GC/RetainerAnalysis.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/GC/RetainerAnalysis.hs @@ -1,24 +1,34 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.GC.RetainerAnalysis where -import Control.Monad.State -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Functor (..), unless) +import Control.Monad.State (MonadIO (..), gets, modify') -import System.Directory -import System.FilePath -import Text.Printf +import Data.Bool (Bool) import qualified Data.ByteString.Char8 as BS8 +import Data.Function (($), (.)) +import Data.List ((++)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid (Monoid (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (String) -import Stg.Interpreter.Base +import Stg.Interpreter.Base (GCSymbol (..), M, StgState (..)) + +import System.Directory (makeAbsolute) +import System.FilePath (()) +import System.IO (IO, putStrLn) + +import Text.Printf (printf) +import Text.Show (Show (..)) loadMap :: String -> IO (Map GCSymbol (Set GCSymbol)) loadMap factPath = do absFactPath <- makeAbsolute factPath putStrLn $ "loading: " ++ show absFactPath - refs <- map BS8.words . BS8.lines <$> BS8.readFile absFactPath + refs <- fmap BS8.words . BS8.lines <$> BS8.readFile absFactPath pure $ Map.fromListWith Set.union [(GCSymbol to, Set.singleton $ GCSymbol from) | [to, from] <- refs] @@ -27,7 +37,7 @@ loadStringSet isQuiet factPath = do absFactPath <- makeAbsolute factPath unless isQuiet $ do putStrLn $ "loading: " ++ show absFactPath - Set.fromList . map GCSymbol . BS8.lines <$> BS8.readFile absFactPath + Set.fromList . fmap GCSymbol . BS8.lines <$> BS8.readFile absFactPath loadRetainerDb :: M () loadRetainerDb = pure () diff --git a/external-stg-interpreter/lib/Stg/Interpreter/IOManager.hs b/external-stg-interpreter/lib/Stg/Interpreter/IOManager.hs index 5f43951..fb6d298 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/IOManager.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/IOManager.hs @@ -1,19 +1,35 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} module Stg.Interpreter.IOManager where -import Control.Monad.State -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Time.Clock - -import Data.Monoid ((<>)) -import Foreign.C.Types -import qualified Language.C.Inline as C +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..), Monad (..), forM_, unless, when) +import Control.Monad.State (MonadIO (..), gets) + +import Data.Function (($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List (maximum, null, (++)) +import Data.Monoid ((<>)) +import Data.Ord (Ord (..)) +import Data.Time.Clock (getCurrentTime) +import Data.Tuple (snd) import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as VM -import Stg.Interpreter.Base +import Foreign.C.Types (CInt (..), CLong (..)) + +import GHC.Err (error) +import GHC.Real (fromIntegral) + +import qualified Language.C.Inline as C + +import Stg.Interpreter.Base (BlockReason (..), M, StgState (..), ThreadState (..), ThreadStatus (..), + getThreadState, updateThreadState) + +import System.IO (IO) + +import Text.Show (Show (..)) -------- I/O manager C.context (C.baseCtx <> C.vecCtx) @@ -147,16 +163,16 @@ fdPollWriteState fd = do handleBlockedDelayWait :: M () handleBlockedDelayWait = do tsList <- gets $ IntMap.toList . fmap tsStatus . ssThreads - now <- liftIO getCurrentTime - let maxSeconds = 31 * 24 * 60 * 60 -- some OS have this constraint - maxDelay = secondsToNominalDiffTime maxSeconds - delaysT = [(tid, t `diffUTCTime` now) | (tid, ThreadBlocked (BlockedOnDelay t)) <- tsList] - minDelay = max 0 $ minimum $ maxDelay : delays + _now <- liftIO getCurrentTime + let -- maxSeconds = 31 * 24 * 60 * 60 -- some OS have this constraint + -- maxDelay = secondsToNominalDiffTime maxSeconds + -- delaysT = [(tid, t `diffUTCTime` now) | (tid, ThreadBlocked (BlockedOnDelay t)) <- tsList] + -- minDelay = max 0 $ minimum $ maxDelay : delays readFDsT = [(tid, fromIntegral fd :: CInt) | (tid, ThreadBlocked (BlockedOnRead fd)) <- tsList] writeFDsT = [(tid, fromIntegral fd :: CInt) | (tid, ThreadBlocked (BlockedOnWrite fd)) <- tsList] - delays = map snd delaysT - readFDs = map snd readFDsT - writeFDs = map snd writeFDsT + -- delays = fmap snd delaysT + readFDs = fmap snd readFDsT + writeFDs = fmap snd writeFDsT fdList = readFDs ++ writeFDs maxFD = maximum fdList -- TODO: detect deadlocks diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimCall.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimCall.hs index 113e3ad..d1e3631 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimCall.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimCall.hs @@ -1,16 +1,23 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.PrimCall where -import Control.Monad.State.Strict -import Foreign +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (MonadIO (..), gets) + +import Data.Function (($)) +import Data.List ((++)) +import Data.Maybe (Maybe) + +import Foreign (Ptr, Storable (..), Word32, Word64, castPtr, with) + +import GHC.Float (Double, Float) +import GHC.Real (fromIntegral) -import Stg.Syntax -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Exceptions +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Exceptions (raiseEx) +import Stg.Syntax (PrimCall (..), TyCon, Type) -pattern WordV i = WordAtom i -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import Text.Show (Show (..)) -- HINT: prim call emulation of .cmm code, because the interpreter FFI does not support Cmm -- the Cmm code operates on the native memory layout @@ -19,7 +26,7 @@ pattern DoubleV d = DoubleAtom d -- NOTE: the WordV should contain a 64 bit wide value evalPrimCallOp :: PrimCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] -evalPrimCallOp pCall@(PrimCall primCallTarget primCallUnitId) args t _tc = do +evalPrimCallOp pCall@(PrimCall primCallTarget _primCallUnitId) args t _tc = do case primCallTarget of -- stg_raiseDivZZerozh :: State# RealWorld -> (# State# RealWorld, Void# #) "stg_raiseDivZZerozh" diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Addr.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Addr.hs index 76f8967..71257a8 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Addr.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Addr.hs @@ -1,31 +1,29 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} +-- {-# LANGUAGE Strict #-} module Stg.Interpreter.PrimOp.Addr where -import Control.Monad.State -import Data.Char -import Data.Word -import Data.Int -import Data.Bits -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import Foreign.Ptr -import Foreign.Storable - -import Stg.Syntax -import Stg.Interpreter.Base - -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (when) +import Control.Monad.State (MonadIO (..)) + +import Data.Bits (Bits (..)) +import Data.Char (Char, chr, ord) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int, Int16, Int32, Int64, Int8) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word, Word16, Word32, Word64, Word8) + +import Foreign.Ptr (IntPtr (..), Ptr, castPtr, intPtrToPtr, minusPtr, plusPtr, ptrToIntPtr, + ptrToWordPtr) +import Foreign.Storable (Storable (..)) + +import GHC.Float (Double, Float) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -373,7 +371,7 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "atomicExchangeWordAddr#", [PtrAtom _ p, WordV value, _s]) -> do liftIO $ do oldValue <- peek (castPtr p :: Ptr Word) - poke (castPtr p :: Ptr Word) (fromIntegral value) + poke (castPtr p :: Ptr Word) value pure [WordV oldValue] -- atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #) @@ -389,7 +387,7 @@ evalPrimOp fallback op args t tc = case (op, args) of liftIO $ do oldValue <- peek (castPtr p :: Ptr Word) when (oldValue == expected) $ do - poke (castPtr p :: Ptr Word) (fromIntegral value) + poke (castPtr p :: Ptr Word) value pure [WordV oldValue] -- atomicCasWord8Addr# :: Addr# -> Word8# -> Word8# -> State# t0 -> (# State# t0, Word8# #) diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Array.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Array.hs index f4c7c50..b6bb88e 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Array.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Array.hs @@ -1,14 +1,21 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.PrimOp.Array where -import Control.Monad.State -import qualified Data.IntMap as IntMap -import qualified Data.Vector as V +import Control.Applicative (Applicative (..)) +import Control.Monad.State (MonadState (..), gets, modify') + +import Data.Eq (Eq (..)) +import Data.Function (($)) +import qualified Data.IntMap as IntMap +import Data.Maybe (Maybe) +import qualified Data.Vector as V + +import GHC.Num (Num (..)) -import Stg.Syntax -import Stg.Interpreter.Base +import Prelude (Enum (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) lookupArrIdx :: ArrIdx -> M (V.Vector Atom) lookupArrIdx = \case diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ArrayArray.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ArrayArray.hs index 2263e96..dd7effa 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ArrayArray.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ArrayArray.hs @@ -1,16 +1,21 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Stg.Interpreter.PrimOp.ArrayArray where -import Control.Monad.State -import qualified Data.IntMap as IntMap -import qualified Data.Vector as V +import Control.Applicative (Applicative (..)) +import Control.Monad.State (gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Eq (Eq (..)) +import Data.Function (($)) +import qualified Data.IntMap as IntMap +import Data.Maybe (Maybe) +import qualified Data.Vector as V -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) lookupArrayArrIdx :: ArrayArrIdx -> M (V.Vector Atom) lookupArrayArrIdx = \case @@ -32,7 +37,7 @@ evalPrimOp fallback op args t tc = case (op, args) of mutableArrayArrays <- gets ssMutableArrayArrays next <- gets ssNextMutableArrayArray let result = MutableArrayArray $ ArrayMutArrIdx next - v = V.replicate (fromIntegral i) result -- wow + v = V.replicate i result -- wow modify' $ \s -> s {ssMutableArrayArrays = IntMap.insert next v mutableArrayArrays, ssNextMutableArrayArray = succ next} pure [result] @@ -47,82 +52,82 @@ evalPrimOp fallback op args t tc = case (op, args) of -- sizeofArrayArray# :: ArrayArray# -> Int# ( "sizeofArrayArray#", [ArrayArray a]) -> do v <- lookupArrayArrIdx a - pure [IntV . fromIntegral $ V.length v] + pure [IntV $ V.length v] -- sizeofMutableArrayArray# :: MutableArrayArray# s -> Int# ( "sizeofMutableArrayArray#", [MutableArrayArray a]) -> do v <- lookupArrayArrIdx a - pure [IntV . fromIntegral $ V.length v] + pure [IntV $ V.length v] -- indexByteArrayArray# :: ArrayArray# -> Int# -> ByteArray# ( "indexByteArrayArray#", [ArrayArray a, IntV i]) -> do v <- lookupArrayArrIdx a - let x@ByteArray{} = v V.! (fromIntegral i) + let x@ByteArray{} = v V.! i pure [x] -- indexArrayArrayArray# :: ArrayArray# -> Int# -> ArrayArray# ( "indexArrayArrayArray#", [ArrayArray a, IntV i]) -> do v <- lookupArrayArrIdx a - let x@ArrayArray{} = v V.! (fromIntegral i) + let x@ArrayArray{} = v V.! i pure [x] -- readByteArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, ByteArray# #) ( "readByteArrayArray#", [MutableArrayArray a, IntV i, _s]) -> do v <- lookupArrayArrIdx a - let x@ByteArray{} = v V.! (fromIntegral i) + let x@ByteArray{} = v V.! i pure [x] -- readMutableByteArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) ( "readMutableByteArrayArray#", [MutableArrayArray a, IntV i, _s]) -> do v <- lookupArrayArrIdx a - let x@MutableByteArray{} = v V.! (fromIntegral i) + let x@MutableByteArray{} = v V.! i pure [x] -- readArrayArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, ArrayArray# #) ( "readArrayArrayArray#", [MutableArrayArray a, IntV i, _s]) -> do v <- lookupArrayArrIdx a - let x@ArrayArray{} = v V.! (fromIntegral i) + let x@ArrayArray{} = v V.! i pure [x] -- readMutableArrayArrayArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) ( "readMutableArrayArrayArray#", [MutableArrayArray a, IntV i, _s]) -> do v <- lookupArrayArrIdx a - let x@MutableArrayArray{} = v V.! (fromIntegral i) + let x@MutableArrayArray{} = v V.! i pure [x] -- writeByteArrayArray# :: MutableArrayArray# s -> Int# -> ByteArray# -> State# s -> State# s ( "writeByteArrayArray#", [MutableArrayArray m, IntV i, a@ByteArray{}, _s]) -> do v <- lookupArrayArrIdx m - updateArrayArrIdx m (v V.// [(fromIntegral i, a)]) + updateArrayArrIdx m (v V.// [(i, a)]) pure [] -- writeMutableByteArrayArray# :: MutableArrayArray# s -> Int# -> MutableByteArray# s -> State# s -> State# s ( "writeMutableByteArrayArray#", [MutableArrayArray m, IntV i, a@MutableByteArray{}, _s]) -> do v <- lookupArrayArrIdx m - updateArrayArrIdx m (v V.// [(fromIntegral i, a)]) + updateArrayArrIdx m (v V.// [(i, a)]) pure [] -- writeArrayArrayArray# :: MutableArrayArray# s -> Int# -> ArrayArray# -> State# s -> State# s ( "writeArrayArrayArray#", [MutableArrayArray m, IntV i, a@ArrayArray{}, _s]) -> do v <- lookupArrayArrIdx m - updateArrayArrIdx m (v V.// [(fromIntegral i, a)]) + updateArrayArrIdx m (v V.// [(i, a)]) pure [] -- writeMutableArrayArrayArray# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> State# s -> State# s ( "writeMutableArrayArrayArray#", [MutableArrayArray m, IntV i, a@MutableArrayArray{}, _s]) -> do v <- lookupArrayArrIdx m - updateArrayArrIdx m (v V.// [(fromIntegral i, a)]) + updateArrayArrIdx m (v V.// [(i, a)]) pure [] -- copyArrayArray# :: ArrayArray# -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s ( "copyArrayArray#", [ArrayArray src, IntV os, MutableArrayArray dst, IntV od, IntV n, _s]) -> do vsrc <- lookupArrayArrIdx src vdst <- lookupArrayArrIdx dst - let vdst' = vdst V.// [ (fromIntegral di, v) + let vdst' = vdst V.// [ (di, v) | i <- [ 0 .. n-1 ] , let si = os + i , let di = od + i - , let v = vsrc V.! (fromIntegral si) + , let v = vsrc V.! si ] updateArrayArrIdx dst vdst' pure [] @@ -131,11 +136,11 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "copyMutableArrayArray#", [MutableArrayArray src, IntV os, MutableArrayArray dst, IntV od, IntV n, _s]) -> do vsrc <- lookupArrayArrIdx src vdst <- lookupArrayArrIdx dst - let vdst' = vdst V.// [ (fromIntegral di, v) + let vdst' = vdst V.// [ (di, v) | i <- [ 0 .. n-1 ] , let si = os + i , let di = od + i - , let v = vsrc V.! (fromIntegral si) + , let v = vsrc V.! si ] updateArrayArrIdx dst vdst' pure [] diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ByteArray.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ByteArray.hs index f8aefa5..69603cf 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ByteArray.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ByteArray.hs @@ -1,31 +1,38 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.ByteArray where -import Data.Bits -import Data.Int -import Data.Word -import Data.Char -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Utils -import Control.Monad.State -import qualified Data.IntMap as IntMap +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (when) +import Control.Monad.State (MonadIO (..), gets, modify') + +import Data.Bits (Bits (..)) +import Data.Bool (Bool (..)) +import Data.Char (Char, chr, ord) +import Data.Eq (Eq ((==))) +import Data.Function (($), (.)) +import Data.Int (Int, Int16, Int32, Int64, Int8) +import qualified Data.IntMap as IntMap +import Data.List ((++)) +import Data.Maybe (Maybe (..)) +import Data.Ord (Ordering (..)) import qualified Data.Primitive.ByteArray as BA +import Data.Word (Word, Word16, Word32, Word64, Word8) -import Stg.Syntax -import Stg.Interpreter.Base - -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Foreign.Marshal.Utils (copyBytes, fillBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToIntPtr) +import Foreign.Storable (Storable (..)) + +import GHC.Float (Double, Float) +import GHC.Num (Num (..)) +import GHC.Real (fromIntegral) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) + +import System.IO (IO) + +import Text.Show (Show (..)) lookupByteArray :: Int -> M BA.ByteArray lookupByteArray baId = do @@ -40,7 +47,7 @@ getByteArrayContentPtr baId = do pure $ BA.mutableByteArrayContents baaMutableByteArray newByteArray :: Int -> Int -> Bool -> M ByteArrayIdx -newByteArray size alignment pinned = do +newByteArray size alignment' pinned = do -- HINT: the implementation always uses pinned byte array because the primop implementation is not atomic -- GC may occur and the content data pointer must stay in place -- but this is only an interpreter implementation constraint @@ -55,7 +62,7 @@ newByteArray size alignment pinned = do { baaMutableByteArray = ba , baaByteArray = Nothing , baaPinned = pinned - , baaAlignment = alignment + , baaAlignment = alignment' } modify' $ \s -> s {ssMutableByteArrays = IntMap.insert next desc byteArrays, ssNextMutableByteArray = succ next} @@ -63,7 +70,7 @@ newByteArray size alignment pinned = do pure $ ByteArrayIdx { baId = next , baPinned = pinned - , baAlignment = alignment + , baAlignment = alignment' } {- @@ -93,8 +100,8 @@ evalPrimOp fallback op args t tc = case (op, args) of -- newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #) - ( "newAlignedPinnedByteArray#", [IntV size, IntV alignment, _s]) -> do - baIdx <- newByteArray size alignment True + ( "newAlignedPinnedByteArray#", [IntV size, IntV alignment', _s]) -> do + baIdx <- newByteArray size alignment' True pure [MutableByteArray baIdx] --------------------------------------------- @@ -136,7 +143,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- resizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) ( "resizeMutableByteArray#", [MutableByteArray baIdx@ByteArrayIdx{..}, IntV newSizeInBytes, _s]) -> do - desc@ByteArrayDescriptor{..} <- lookupByteArrayDescriptor baId + ByteArrayDescriptor{..} <- lookupByteArrayDescriptor baId -- sanity check when baaPinned $ do stgErrorM $ "(undefined behaviour) resizeMutableByteArray# on pinned MutableByteArray, primop args: " ++ show args @@ -167,17 +174,20 @@ evalPrimOp fallback op args t tc = case (op, args) of -- sizeofByteArray# :: ByteArray# -> Int# ( "sizeofByteArray#", [ByteArray ByteArrayIdx{..}]) -> do ByteArrayDescriptor{..} <- lookupByteArrayDescriptor baId - pure [IntV $ BA.sizeofMutableByteArray baaMutableByteArray] + sz <- BA.getSizeofMutableByteArray baaMutableByteArray + pure [IntV sz] -- sizeofMutableByteArray# :: MutableByteArray# s -> Int# ( "sizeofMutableByteArray#", [MutableByteArray ByteArrayIdx{..}]) -> do ByteArrayDescriptor{..} <- lookupByteArrayDescriptor baId - pure [IntV $ BA.sizeofMutableByteArray baaMutableByteArray] + sz <- BA.getSizeofMutableByteArray baaMutableByteArray + pure [IntV sz] -- getSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (# State# s, Int# #) ( "getSizeofMutableByteArray#", [MutableByteArray ByteArrayIdx{..}, _s]) -> do ByteArrayDescriptor{..} <- lookupByteArrayDescriptor baId - pure [IntV $ BA.sizeofMutableByteArray baaMutableByteArray] + sz <- BA.getSizeofMutableByteArray baaMutableByteArray + pure [IntV sz] --------------------------------------------- -- read ByteArray (pure) @@ -751,15 +761,15 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "compareByteArrays#", [ ByteArray ByteArrayIdx{baId = baIdA}, IntV offsetA , ByteArray ByteArrayIdx{baId = baIdB}, IntV offsetB - , IntV length + , IntV length' ] ) -> do baA <- lookupByteArray baIdA baB <- lookupByteArray baIdB - case BA.compareByteArrays baA offsetA baB offsetB length of - LT -> pure [IntV (-1)] - EQ -> pure [IntV 0] - GT -> pure [IntV 1] + case BA.compareByteArrays baA offsetA baB offsetB length' of + LT -> pure [IntV (-1)] + EQ -> pure [IntV 0] + GT -> pure [IntV 1] --------------------------------------------- -- copy and fill @@ -769,48 +779,48 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "copyByteArray#", [ ByteArray ByteArrayIdx{baId = baIdSrc}, IntV offsetSrc , MutableByteArray ByteArrayIdx{baId = baIdDst}, IntV offsetDst - , IntV length, _s + , IntV length', _s ] ) -> do src <- getByteArrayContentPtr baIdSrc dst <- getByteArrayContentPtr baIdDst - liftIO $ copyBytes (plusPtr dst offsetDst) (plusPtr src offsetSrc) length + liftIO $ copyBytes (plusPtr dst offsetDst) (plusPtr src offsetSrc) length' pure [] -- copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s ( "copyMutableByteArray#", [ MutableByteArray ByteArrayIdx{baId = baIdSrc}, IntV offsetSrc , MutableByteArray ByteArrayIdx{baId = baIdDst}, IntV offsetDst - , IntV length, _s + , IntV length', _s ] ) -> do src <- getByteArrayContentPtr baIdSrc dst <- getByteArrayContentPtr baIdDst - liftIO $ copyBytes (plusPtr dst offsetDst) (plusPtr src offsetSrc) length + liftIO $ copyBytes (plusPtr dst offsetDst) (plusPtr src offsetSrc) length' pure [] -- copyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s - ( "copyByteArrayToAddr#", [ByteArray ByteArrayIdx{..}, IntV offset, PtrAtom _ dst, IntV length, _s]) -> do + ( "copyByteArrayToAddr#", [ByteArray ByteArrayIdx{..}, IntV offset, PtrAtom _ dst, IntV length', _s]) -> do p <- getByteArrayContentPtr baId - liftIO $ copyBytes dst (plusPtr p offset) length + liftIO $ copyBytes dst (plusPtr p offset) length' pure [] -- copyMutableByteArrayToAddr# :: MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s - ( "copyMutableByteArrayToAddr#", [MutableByteArray ByteArrayIdx{..}, IntV offset, PtrAtom _ dst, IntV length, _s]) -> do + ( "copyMutableByteArrayToAddr#", [MutableByteArray ByteArrayIdx{..}, IntV offset, PtrAtom _ dst, IntV length', _s]) -> do p <- getByteArrayContentPtr baId - liftIO $ copyBytes dst (plusPtr p offset) length + liftIO $ copyBytes dst (plusPtr p offset) length' pure [] -- copyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - ( "copyAddrToByteArray#", [PtrAtom _ src, MutableByteArray ByteArrayIdx{..}, IntV offset, IntV length, _s]) -> do + ( "copyAddrToByteArray#", [PtrAtom _ src, MutableByteArray ByteArrayIdx{..}, IntV offset, IntV length', _s]) -> do p <- getByteArrayContentPtr baId - liftIO $ copyBytes (plusPtr p offset) src length + liftIO $ copyBytes (plusPtr p offset) src length' pure [] -- setByteArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s - ( "setByteArray#", [MutableByteArray ByteArrayIdx{..}, IntV offset, IntV length, IntV value, _s]) -> do + ( "setByteArray#", [MutableByteArray ByteArrayIdx{..}, IntV offset, IntV length', IntV value, _s]) -> do p <- getByteArrayContentPtr baId - liftIO $ fillBytes (plusPtr p offset) (fromIntegral value :: Word8) length + liftIO $ fillBytes (plusPtr p offset) (fromIntegral value :: Word8) length' pure [] --------------------------------------------- @@ -832,48 +842,48 @@ evalPrimOp fallback op args t tc = case (op, args) of pure [] -- casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) - ( "casIntArray#", [MutableByteArray ByteArrayIdx{..}, IntV index, IntV old, IntV new, _s]) -> do + ( "casIntArray#", [MutableByteArray ByteArrayIdx{..}, IntV index, IntV old, IntV new', _s]) -> do p <- getByteArrayContentPtr baId -- NOTE: CPU atomic current <- liftIO (peekElemOff (castPtr p) index :: IO Int) when (current == old) $ do - liftIO $ pokeElemOff (castPtr p) index new + liftIO $ pokeElemOff (castPtr p) index new' pure [IntV current] -- casInt8Array# :: MutableByteArray# t0 -> Int# -> Int8# -> Int8# -> State# t0 -> (# State# t0, Int8# #) - ( "casInt8Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int8V old, Int8V new, _s]) -> do + ( "casInt8Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int8V old, Int8V new', _s]) -> do p <- getByteArrayContentPtr baId -- NOTE: CPU atomic current <- fromIntegral <$> liftIO (peekElemOff (castPtr p) index :: IO Int8) when (current == old) $ do - liftIO $ pokeElemOff (castPtr p) index new + liftIO $ pokeElemOff (castPtr p) index new' pure [Int8V current] -- casInt16Array# :: MutableByteArray# t0 -> Int# -> Int16# -> Int16# -> State# t0 -> (# State# t0, Int16# #) - ( "casInt16Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int16V old, Int16V new, _s]) -> do + ( "casInt16Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int16V old, Int16V new', _s]) -> do p <- getByteArrayContentPtr baId -- NOTE: CPU atomic current <- fromIntegral <$> liftIO (peekElemOff (castPtr p) index :: IO Int16) when (current == old) $ do - liftIO $ pokeElemOff (castPtr p) index new + liftIO $ pokeElemOff (castPtr p) index new' pure [Int16V current] -- casInt32Array# :: MutableByteArray# t0 -> Int# -> Int32# -> Int32# -> State# t0 -> (# State# t0, Int32# #) - ( "casInt32Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int32V old, Int32V new, _s]) -> do + ( "casInt32Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int32V old, Int32V new', _s]) -> do p <- getByteArrayContentPtr baId -- NOTE: CPU atomic current <- fromIntegral <$> liftIO (peekElemOff (castPtr p) index :: IO Int32) when (current == old) $ do - liftIO $ pokeElemOff (castPtr p) index new + liftIO $ pokeElemOff (castPtr p) index new' pure [Int32V current] -- casInt64Array# :: MutableByteArray# t0 -> Int# -> Int64# -> Int64# -> State# t0 -> (# State# t0, Int64# #) - ( "casInt64Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int64V old, Int64V new, _s]) -> do + ( "casInt64Array#", [MutableByteArray ByteArrayIdx{..}, IntV index, Int64V old, Int64V new', _s]) -> do p <- getByteArrayContentPtr baId -- NOTE: CPU atomic current <- fromIntegral <$> liftIO (peekElemOff (castPtr p) index :: IO Int64) when (current == old) $ do - liftIO $ pokeElemOff (castPtr p) index new + liftIO $ pokeElemOff (castPtr p) index new' pure [Int64V current] -- fetchAddIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Char.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Char.hs index d86a104..f011208 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Char.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Char.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} module Stg.Interpreter.PrimOp.Char where -import Data.Char +import Control.Applicative (Applicative (..)) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Char (ord) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -33,6 +33,6 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "leChar#", [CharV a, CharV b]) -> pure [IntV $ if a <= b then 1 else 0] -- ord# :: Char# -> Int# - ( "ord#", [CharV c]) -> pure [IntV . fromIntegral $ ord c] + ( "ord#", [CharV c]) -> pure [IntV $ ord c] - _ -> fallback op args t tc + _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Compact.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Compact.hs index 2e98bae..4e1bcb9 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Compact.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Compact.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} + module Stg.Interpreter.PrimOp.Compact where -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Maybe (Maybe) + +import Stg.Interpreter.Base (Atom, M, PrimOpEval) +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] -evalPrimOp fallback op args t tc = case (op, args) of +evalPrimOp fallback = fallback -- compactNew# :: Word# -> State# RealWorld -> (# State# RealWorld, Compact# #) -- compactResize# :: Compact# -> Word# -> State# RealWorld -> State# RealWorld @@ -19,7 +21,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- compactAddWithSharing# :: Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) -- compactSize# :: Compact# -> State# RealWorld -> (# State# RealWorld, Word# #) - _ -> fallback op args t tc + -- _ -> fallback op args t tc {- ------------------------------------------------------------------------ @@ -144,4 +146,4 @@ primop CompactSize "compactSize#" GenPrimOp with has_side_effects = True out_of_line = True --} \ No newline at end of file +-} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Concurrency.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Concurrency.hs index cd0bb8e..f3d18b0 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Concurrency.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Concurrency.hs @@ -1,15 +1,28 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.Concurrency where -import Control.Monad.State +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Monad (..), when) +import Control.Monad.State (MonadIO (..), gets, modify') + +import Data.Bool (Bool (..), not, otherwise, (||)) import qualified Data.ByteString.Char8 as BS8 -import qualified Data.IntMap as IntMap -import Foreign.Ptr +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List (drop, filter, null, reverse, (++)) +import Data.Maybe (Maybe (..), fromJust) + +import Foreign.Ptr (castPtr) + +import GHC.Err (error, undefined) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) -import Stg.Syntax -import Stg.Interpreter.Base +import System.IO (print, putStrLn) -pattern IntV i = IntAtom i +import Text.Show (Show (..)) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -70,79 +83,77 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "killThread#", [ThreadId tidTarget, exception, _s]) -> do tid <- gets ssCurrentThreadId mylog $ "killThread# current-tid: " ++ show tid ++ " target-tid: " ++ show tidTarget - case tid == tidTarget of - True -> do - mylog "killMyself" - -- killMyself - {- + if tid == tidTarget then do + mylog "killMyself" + -- killMyself + {- the thread might survive Q: how? A: a catch frame can save the thread so that it will handle the exception -} - removeFromQueues tidTarget - let myResult = [] -- HINT: this is the result of the killThread# primop - raiseAsyncEx myResult tidTarget exception - - -- TODO: remove this below, problem: raiseAsyncEx may kill the thread ; model kill thread as return to scheduler operation with a descriptive reason - -- return the result that the raise async ex has calculated - tsCurrentResult <$> getCurrentThreadState - - False -> do - -- kill other thread - targetTS <- getThreadState tidTarget - mylog $ "kill other thread " ++ show tidTarget ++ " " ++ show (tsStatus targetTS, tsBlockExceptions targetTS, tsInterruptible targetTS) - - let blockIfNotInterruptible_raiseOtherwise - | tsBlockExceptions targetTS - , not (tsInterruptible targetTS) = block - | otherwise = raise - - blockIfBlocked_raiseOtherwise - | tsBlockExceptions targetTS = block - | otherwise = raise - - block = do - mylog "block" - -- add our thread id and exception to target's blocked excpetions queue - updateThreadState tidTarget (targetTS {tsBlockedExceptions = (tid, exception) : tsBlockedExceptions targetTS}) - -- block our thread - myTS <- getCurrentThreadState - updateThreadState tid (myTS {tsStatus = ThreadBlocked $ BlockedOnThrowAsyncEx tidTarget}) - - when False $ do - reportThread tidTarget - error $ "BlockedOnThrowAsyncEx, targetTS.tsStatus = " ++ show (tsStatus targetTS) ++ " targetTS.mask: " ++ show (tsBlockExceptions targetTS, tsInterruptible targetTS) - - --liftIO $ putStrLn $ " * killThread#, blocked tid: " ++ show tid - -- push reschedule continuation, reason: block - stackPush $ RunScheduler SR_ThreadBlocked - mylog "block - end" - --reportThread tid - --reportThread tidTarget - pure [] - - raise = do - mylog "raise" - removeFromQueues tidTarget - raiseAsyncEx (tsCurrentResult targetTS) tidTarget exception - mylog "raise - end" - pure [] - - case tsStatus targetTS of - ThreadFinished -> pure [] -- NOTE: nothing to do - ThreadDied -> pure [] -- NOTE: nothing to do - ThreadRunning -> blockIfBlocked_raiseOtherwise - ThreadBlocked blockReason -> case blockReason of - - BlockedOnForeignCall{} -> block - BlockedOnBlackHole{} -> blockIfBlocked_raiseOtherwise - BlockedOnThrowAsyncEx{} -> blockIfNotInterruptible_raiseOtherwise - BlockedOnSTM{} -> blockIfNotInterruptible_raiseOtherwise - BlockedOnMVar{} -> blockIfNotInterruptible_raiseOtherwise - BlockedOnMVarRead{} -> blockIfNotInterruptible_raiseOtherwise - BlockedOnRead{} -> blockIfNotInterruptible_raiseOtherwise - BlockedOnWrite{} -> blockIfNotInterruptible_raiseOtherwise - BlockedOnDelay{} -> blockIfNotInterruptible_raiseOtherwise + removeFromQueues tidTarget + let myResult = [] -- HINT: this is the result of the killThread# primop + raiseAsyncEx myResult tidTarget exception + + -- TODO: remove this below, problem: raiseAsyncEx may kill the thread ; model kill thread as return to scheduler operation with a descriptive reason + -- return the result that the raise async ex has calculated + tsCurrentResult <$> getCurrentThreadState + else do + -- kill other thread + targetTS <- getThreadState tidTarget + mylog $ "kill other thread " ++ show tidTarget ++ " " ++ show (tsStatus targetTS, tsBlockExceptions targetTS, tsInterruptible targetTS) + + let blockIfNotInterruptible_raiseOtherwise + | tsBlockExceptions targetTS + , not (tsInterruptible targetTS) = block + | otherwise = raise + + blockIfBlocked_raiseOtherwise + | tsBlockExceptions targetTS = block + | otherwise = raise + + block = do + mylog "block" + -- add our thread id and exception to target's blocked excpetions queue + updateThreadState tidTarget (targetTS {tsBlockedExceptions = (tid, exception) : tsBlockedExceptions targetTS}) + -- block our thread + myTS <- getCurrentThreadState + updateThreadState tid (myTS {tsStatus = ThreadBlocked $ BlockedOnThrowAsyncEx tidTarget}) + + when False $ do + reportThread tidTarget + error $ "BlockedOnThrowAsyncEx, targetTS.tsStatus = " ++ show (tsStatus targetTS) ++ " targetTS.mask: " ++ show (tsBlockExceptions targetTS, tsInterruptible targetTS) + + --liftIO $ putStrLn $ " * killThread#, blocked tid: " ++ show tid + -- push reschedule continuation, reason: block + stackPush $ RunScheduler SR_ThreadBlocked + mylog "block - end" + --reportThread tid + --reportThread tidTarget + pure [] + + raise = do + mylog "raise" + removeFromQueues tidTarget + raiseAsyncEx (tsCurrentResult targetTS) tidTarget exception + mylog "raise - end" + pure [] + + case tsStatus targetTS of + ThreadFinished -> pure [] -- NOTE: nothing to do + ThreadDied -> pure [] -- NOTE: nothing to do + ThreadRunning -> blockIfBlocked_raiseOtherwise + ThreadBlocked blockReason -> case blockReason of + + BlockedOnForeignCall{} -> block + BlockedOnBlackHole{} -> blockIfBlocked_raiseOtherwise + BlockedOnThrowAsyncEx{} -> blockIfNotInterruptible_raiseOtherwise + BlockedOnSTM{} -> blockIfNotInterruptible_raiseOtherwise + BlockedOnMVar{} -> blockIfNotInterruptible_raiseOtherwise + BlockedOnMVarRead{} -> blockIfNotInterruptible_raiseOtherwise + BlockedOnRead{} -> blockIfNotInterruptible_raiseOtherwise + BlockedOnWrite{} -> blockIfNotInterruptible_raiseOtherwise + BlockedOnDelay{} -> blockIfNotInterruptible_raiseOtherwise -- yield# :: State# RealWorld -> State# RealWorld ( "yield#", [_s]) -> do @@ -157,7 +168,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- labelThread# :: ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld ( "labelThread#", [ThreadId tid, PtrAtom _ p, _s]) -> do threadLabel <- liftIO . BS8.packCString $ castPtr p - let setLabel ts@ThreadState{..} = ts {tsLabel = Just threadLabel} + let setLabel ts = ts {tsLabel = Just threadLabel} modify' $ \s@StgState{..} -> s {ssThreads = IntMap.adjust setLabel tid ssThreads} pure [] @@ -213,13 +224,13 @@ raiseAsyncEx lastResult targetTid exception = do , tsStatus = ThreadRunning -- HINT: whatever blocked this thread now that operation got cancelled by the async exception -- NOTE: Ensure that async exceptions are blocked now, so we don't get a surprise exception before we get around to executing the handler. , tsBlockExceptions = True - , tsInterruptible = if bEx then iEx else True + , tsInterruptible = not bEx || iEx } --liftIO $ putStrLn $ "set mask - " ++ show targetTid ++ " raiseAsyncEx b:True i:" ++ show (if bEx then iEx else True) -- replace Update with ApStack Update addr : stackTail -> do - when (result == []) $ error "internal error - result should be a [HeapPtr], but it's value is []" + when (null result) $ error "internal error - result should be a [HeapPtr], but it's value is []" let apStack = ApStack { hoResult = result , hoStack = reverse stackPiece @@ -241,7 +252,7 @@ raiseAsyncEx lastResult targetTid exception = do reportThread targetTid error "internal error" _ -> pure () - let Just tlog = tsActiveTLog ts + let _tlog = fromJust $ tsActiveTLog ts -- HINT: abort transaction, do not need to unsubscribe, because it was already done in killThread# before it called raiseAsyncEx updateThreadState targetTid $ ts {tsActiveTLog = Nothing} unwindStack result (AtomicallyOp stmAction : stackPiece) stackTail @@ -256,8 +267,11 @@ raiseAsyncEx lastResult targetTid exception = do reportThread targetTid error "internal error" _ -> pure () - let Just tlog = tsActiveTLog ts - tlogStackTop : tlogStackTail = tsTLogStack ts + let _tlog = fromJust $ tsActiveTLog ts + (tlogStackTop, tlogStackTail) = + case tsTLogStack ts of + [] -> undefined + (a : b) -> (a, b) -- HINT: abort transaction, do not need to unsubscribe, because it was already done in killThread# before it called raiseAsyncEx mylog $ show targetTid ++ " ** raiseAsyncEx - CatchSTM" updateThreadState targetTid $ ts @@ -277,8 +291,8 @@ raiseAsyncEx lastResult targetTid exception = do reportThread targetTid error "internal error" _ -> pure () - let Just tlog = tsActiveTLog ts - updateThreadState targetTid $ ts { tsTLogStack = tail $ tsTLogStack ts } + let _tlog = fromJust $ tsActiveTLog ts + updateThreadState targetTid $ ts { tsTLogStack = drop 1 $ tsTLogStack ts } unwindStack result (stackHead : stackPiece) stackTail -- collect stack frames for ApStack @@ -302,7 +316,7 @@ removeFromQueues tid = do ThreadBlocked BlockedOnWrite{} -> pure () -- HINT: no queue for file write ThreadBlocked BlockedOnThrowAsyncEx{} -> pure () -- Q: what to do? ThreadBlocked (BlockedOnBlackHole addr) -> removeFromBlackHoleQueue tid addr - _ -> error $ "TODO: removeFromQueues " ++ show tsStatus + _ -> error $ "TODO: removeFromQueues " ++ show tsStatus removeFromMVarQueue :: Int -> Int -> M () removeFromMVarQueue tid m = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/DelayWait.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/DelayWait.hs index d1a5906..21edfc1 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/DelayWait.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/DelayWait.hs @@ -1,14 +1,23 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.DelayWait where -import Control.Monad.State -import Data.Time.Clock -import Data.Fixed +import Control.Applicative (Applicative (..)) +import Control.Monad (unless) +import Control.Monad.State (MonadIO (..), gets) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Eq (Eq (..)) +import Data.Fixed (Pico) +import Data.Function (($)) +import Data.List ((++)) +import Data.Maybe (Maybe) +import Data.Time.Clock (addUTCTime, getCurrentTime, secondsToNominalDiffTime) -pattern IntV i = IntAtom i +import GHC.Err (error) +import GHC.Real (Fractional (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) + +import Text.Show (Show (..)) {- NOTE: diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Double.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Double.hs index 8b8ed73..ef4f813 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Double.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Double.hs @@ -1,18 +1,22 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, Strict #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE UnboxedTuples #-} module Stg.Interpreter.PrimOp.Double where -import GHC.Word -import GHC.Int -import GHC.Float -import GHC.Exts -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) + +import GHC.Exts +import GHC.Float (Floating (..), acoshDouble, asinhDouble, atanhDouble, expm1Double, log1pDouble) +import GHC.Num (Num (..)) +import GHC.Real (Fractional (..), RealFrac (..), realToFrac) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -115,14 +119,15 @@ evalPrimOp fallback op args t tc = case (op, args) of -- decodeDouble_2Int# :: Double# -> (# Int#, Word#, Word#, Int# #) ( "decodeDouble_2Int#", [DoubleV (D# x)]) -> do - -- NOTE: map back to GHC primop + -- NOTE: fmap back to GHC primop let !(# a, b, c, d #) = decodeDouble_2Int# x pure [IntV (I# a), WordV (W# b), WordV (W# c), IntV (I# d)] -- decodeDouble_Int64# :: Double# -> (# Int64#, Int# #) ( "decodeDouble_Int64#", [DoubleV (D# x)]) -> do - -- NOTE: map back to GHC primop + -- NOTE: fmap back to GHC primop let !(# a, b #) = decodeDouble_Int64# x - pure [Int64V (I# a), IntV (I# b)] + let a' = int64ToInt# a + pure [Int64V (I# a'), IntV (I# b)] _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Exceptions.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Exceptions.hs index a3f8e9f..bb47be0 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Exceptions.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Exceptions.hs @@ -1,13 +1,25 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.Exceptions where -import Control.Monad.State +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..), unless, when) +import Control.Monad.State (MonadIO (..), gets) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Bool (Bool (..), not, (&&), (||)) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.List (drop, null) +import Data.Maybe (Maybe (..), fromJust) +import Data.Monoid (Monoid (..)) + +import GHC.Err (error, undefined) + +import Stg.Interpreter.Base import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency +import Stg.Syntax (Name, TyCon, Type) + +import System.IO (print) -pattern IntV i = IntAtom i +import Text.Show (Show (..)) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -53,7 +65,7 @@ evalPrimOp fallback op args t tc = case (op, args) of raiseEx rtsOverflowException -- raiseIO# :: a -> State# RealWorld -> (# State# RealWorld, b #) - ( "raiseIO#", [ex, s]) -> do + ( "raiseIO#", [ex, _s]) -> do tid <- gets ssCurrentThreadId mylog $ show (tid, op, args) -- for debug only @@ -76,7 +88,7 @@ evalPrimOp fallback op args t tc = case (op, args) of ------------------------ debug -- set new masking state - unless (tsBlockExceptions == True && tsInterruptible == True) $ do + unless (tsBlockExceptions && tsInterruptible) $ do updateThreadState tid $ ts {tsBlockExceptions = True, tsInterruptible = True} --liftIO $ putStrLn $ "set mask - " ++ show tid ++ " maskAsyncExceptions# b:True i:True" stackPush $ RestoreExMask (True, True) tsBlockExceptions tsInterruptible @@ -100,7 +112,7 @@ evalPrimOp fallback op args t tc = case (op, args) of ------------------------ debug -- set new masking state - unless (tsBlockExceptions == True && tsInterruptible == False) $ do + unless (tsBlockExceptions && not tsInterruptible) $ do updateThreadState tid $ ts {tsBlockExceptions = True, tsInterruptible = False} --liftIO $ putStrLn $ "set mask - " ++ show tid ++ " maskUninterruptible# b:True i:False" stackPush $ RestoreExMask (True, False) tsBlockExceptions tsInterruptible @@ -124,8 +136,8 @@ evalPrimOp fallback op args t tc = case (op, args) of when (tsStatus throwingTS == ThreadBlocked (BlockedOnThrowAsyncEx tid)) $ do updateThreadState thowingTid throwingTS {tsStatus = ThreadRunning} -- raise exception - ts <- getCurrentThreadState - updateThreadState tid ts {tsBlockedExceptions = waitingTids} + ts' <- getCurrentThreadState + updateThreadState tid ts' {tsBlockedExceptions = waitingTids} -- run action stackPush $ Apply [w] -- HINT: the stack may be captured by ApStack if there is an Update frame, -- so we have to setup the continuation properly @@ -133,11 +145,10 @@ evalPrimOp fallback op args t tc = case (op, args) of pure [] [] -> do -- set new masking state - unless (tsBlockExceptions ts == False && tsInterruptible ts == False) $ do + unless (not (tsBlockExceptions ts) && not (tsInterruptible ts)) $ do updateThreadState tid $ ts {tsBlockExceptions = False, tsInterruptible = False} --liftIO $ putStrLn $ "set mask - " ++ show tid ++ " unmaskAsyncExceptions# b:False i:False" stackPush $ RestoreExMask (False, False) (tsBlockExceptions ts) (tsInterruptible ts) - pure () -- run action stackPush $ Apply [w] pure [f] @@ -192,10 +203,10 @@ evalPrimOp fallback op args t tc = case (op, args) of 2 == masked, interruptible -} let status = case (tsBlockExceptions, tsInterruptible) of - (False, False) -> 0 - (True, False) -> 1 - (True, True) -> 2 - (False, True) -> error "impossible exception mask, tsBlockExceptions: False, tsInterruptible: True" + (False, False) -> 0 + (True, False) -> 1 + (True, True) -> 2 + (False, True) -> error "impossible exception mask, tsBlockExceptions: False, tsInterruptible: True" pure [IntV status] _ -> fallback op args t tc @@ -235,13 +246,12 @@ int maybePerformBlockedException (Capability *cap, StgTSO *tso) -- Returns: non- raiseEx :: Atom -> M [Atom] raiseEx a = do - tid <- gets ssCurrentThreadId + _tid <- gets ssCurrentThreadId --mylog $ "pre - raiseEx, current-result: " ++ show a --reportThread tid - result <- raiseEx0 a + raiseEx0 a --mylog $ "post - raiseEx, next-result: " ++ show result --reportThread tid - pure result raiseEx0 :: Atom -> M [Atom] raiseEx0 ex = unwindStack where @@ -259,9 +269,9 @@ raiseEx0 ex = unwindStack where -- mask async exceptions before running the handler ts <- getCurrentThreadState tid <- gets ssCurrentThreadId - updateThreadState tid $ ts {tsBlockExceptions = True, tsInterruptible = if bEx then iEx else True} + updateThreadState tid $ ts {tsBlockExceptions = True, tsInterruptible = not bEx || iEx} unless bEx $ do - stackPush $ RestoreExMask (True, if bEx then iEx else True) bEx iEx + stackPush $ RestoreExMask (True, not bEx || iEx) bEx iEx -- run the exception handler stackPush $ Apply [ex, Void] @@ -270,7 +280,10 @@ raiseEx0 ex = unwindStack where Just (CatchSTM _stmAction exHandler) -> do ts <- getCurrentThreadState tid <- gets ssCurrentThreadId - let tlogStackTop : tlogStackTail = tsTLogStack ts + let (tlogStackTop, tlogStackTail) = + case tsTLogStack ts of + [] -> undefined + (a : b) -> (a, b) -- HINT: abort current nested transaction, and reload the parent tlog then run the exception handler in it --mylog $ show tid ++ " ** CatchSTM" updateThreadState tid $ ts @@ -284,7 +297,7 @@ raiseEx0 ex = unwindStack where Just CatchRetry{} -> do ts <- getCurrentThreadState tid <- gets ssCurrentThreadId - updateThreadState tid $ ts { tsTLogStack = tail $ tsTLogStack ts} + updateThreadState tid $ ts { tsTLogStack = drop 1 $ tsTLogStack ts} unwindStack Just (Update addr) -> do @@ -302,16 +315,15 @@ raiseEx0 ex = unwindStack where tid <- gets ssCurrentThreadId -- extra validation (optional) when (tsTLogStack ts /= []) $ error "internal error: non-empty tsTLogStack without tsActiveTLog" - let Just tlog = tsActiveTLog ts + let tlog = fromJust $ tsActiveTLog ts isValid <- validateTLog tlog - case isValid of - True -> do + if isValid then do -- abandon transaction --mylog $ show tid ++ " ** Atomically - valid" updateThreadState tid $ ts {tsActiveTLog = Nothing} --unsubscribeTVarWaitQueues tid tlog unwindStack - False -> do + else do --mylog $ show tid ++ " ** Atomically - invalid" -- restart transaction due to invalid STM state -- Q: what about async exceptions? diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Float.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Float.hs index e11c82f..38f82c8 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Float.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Float.hs @@ -1,17 +1,23 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} -{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE UnboxedTuples #-} module Stg.Interpreter.PrimOp.Float where -import GHC.Exts -import GHC.Float -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) + +import GHC.Exts +import GHC.Float (Floating (..), acoshFloat, asinhFloat, atanhFloat, expm1Float, log1pFloat, + powerFloat) +import GHC.Num (Num (..)) +import GHC.Real (Fractional (..), RealFrac (..), realToFrac) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -114,7 +120,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- decodeFloat_Int# :: Float# -> (# Int#, Int# #) ( "decodeFloat_Int#", [FloatV (F# a)]) -> do - let !(# mantissa, exponent #) = decodeFloat_Int# a - pure [IntV (I# mantissa), IntV (I# exponent)] + let !(# mantissa, exponent' #) = decodeFloat_Int# a + pure [IntV (I# mantissa), IntV (I# exponent')] _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/GHCiBytecode.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/GHCiBytecode.hs index 360f6c6..0a9fdc9 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/GHCiBytecode.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/GHCiBytecode.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.PrimOp.GHCiBytecode where -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Maybe (Maybe) + +import Stg.Interpreter.Base (Atom, M, PrimOpEval) +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] -evalPrimOp fallback op args t tc = case (op, args) of +evalPrimOp fallback = fallback - _ -> fallback op args t tc + -- _ -> fallback op args t tc {- ------------------------------------------------------------------------ @@ -80,4 +81,4 @@ primop GetApStackValOp "getApStackVal#" GenPrimOp a -> Int# -> (# Int#, b #) with out_of_line = True --} \ No newline at end of file +-} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/InfoTableOrigin.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/InfoTableOrigin.hs index 10aca30..dd4133f 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/InfoTableOrigin.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/InfoTableOrigin.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.InfoTableOrigin where -import Foreign.Ptr +import Control.Applicative (Applicative (..)) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Maybe (Maybe) + +import Foreign.Ptr (nullPtr) + +import Stg.Interpreter.Base (Atom (..), M, PrimOpEval, PtrOrigin (..)) +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -12,4 +15,4 @@ evalPrimOp fallback op args t tc = case (op, args) of -- whereFrom# :: a -> State# s -> (# State# s, Addr# #) ( "whereFrom#", [_a, _s]) -> pure [PtrAtom InfoTablePtr nullPtr] - _ -> fallback op args t tc + _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int.hs index 7c4b610..8083c3b 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int.hs @@ -1,24 +1,31 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} -{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE UnboxedTuples #-} module Stg.Interpreter.PrimOp.Int where -import GHC.Exts -import Foreign.Storable (sizeOf) -import Data.Int -import Data.Word -import Data.Bits -import Data.Char +import Control.Applicative (Applicative (..)) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Bits (Bits (..)) +import Data.Bool ((||)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int64) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word64) -type PrimInt = Int64 +import Foreign.Storable (sizeOf) + +import GHC.Exts +import GHC.Num (Integer, Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Prelude (Bounded (..)) -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) + +type PrimInt = Int64 evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -48,7 +55,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- Return either 00..00 or FF..FF depending on the carry carryFill :: Int -> Int - carryFill x = x `shiftR` (wordSizeInBits - 1) + carryFill x' = x' `shiftR` (wordSizeInBits - 1) wordSizeInBits :: Int wordSizeInBits = 8 * sizeOf (0 :: Word) diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int16.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int16.hs index 8192ca4..7a9a43f 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int16.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int16.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} +-- {-# LANGUAGE Strict #-} module Stg.Interpreter.PrimOp.Int16 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Int -import Data.Word -import Data.Bits +import Data.Bits (Bits (unsafeShiftL, unsafeShiftR)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int, Int16) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word16) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int32.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int32.hs index e1a83da..635d06c 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int32.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int32.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} +-- {-# LANGUAGE Strict #-} module Stg.Interpreter.PrimOp.Int32 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Int -import Data.Word -import Data.Bits +import Data.Bits (Bits (unsafeShiftL, unsafeShiftR)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int, Int32) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word32) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int64.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int64.hs index 3ac6fb9..d74b3c4 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int64.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int64.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} +-- {-# LANGUAGE Strict #-} module Stg.Interpreter.PrimOp.Int64 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Int -import Data.Word -import Data.Bits +import Data.Bits (Bits (unsafeShiftL, unsafeShiftR)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int, Int64) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word64) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int8.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int8.hs index b1acd1b..abae658 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int8.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int8.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} +-- {-# LANGUAGE Strict #-} module Stg.Interpreter.PrimOp.Int8 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Int -import Data.Word -import Data.Bits +import Data.Bits (Bits (unsafeShiftL, unsafeShiftR)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int, Int8) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word8) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MVar.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MVar.hs index 1cda0ea..6ce8a74 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MVar.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MVar.hs @@ -1,18 +1,26 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.MVar where -import Control.Monad.State -import qualified Data.IntMap as IntMap +import Control.Applicative (Applicative (..)) +import Control.Monad.State (MonadState (..), gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List ((++)) +import Data.Maybe (Maybe (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Err (error) -handleTakeMVar_ValueFullCase :: Int -> MVarDescriptor -> M () -handleTakeMVar_ValueFullCase m mvd@MVarDescriptor{..} = do +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) + +import Text.Show (Show (..)) + +handleTakeMVarValueFullCase :: Int -> MVarDescriptor -> M () +handleTakeMVarValueFullCase m mvd@MVarDescriptor{..} = do case mvdQueue of [] -> do -- HINT: the queue is empty so there is nothing to do, just mark the mvar empty @@ -30,8 +38,8 @@ handleTakeMVar_ValueFullCase m mvd@MVarDescriptor{..} = do modify' $ \s@StgState{..} -> s {ssMVars = IntMap.insert m newValue ssMVars } _ -> error $ "internal error - invalid thread status: " ++ show (tsStatus ts) -handlePutMVar_ValueEmptyCase :: Int -> MVarDescriptor -> Atom -> M () -handlePutMVar_ValueEmptyCase m mvd@MVarDescriptor{..} v = do +handlePutMVarValueEmptyCase :: Int -> MVarDescriptor -> Atom -> M () +handlePutMVarValueEmptyCase m mvd@MVarDescriptor{..} v = do -- HINT: first handle the blocked readMVar case, it does not consume the value -- BlockedOnMVarRead are always at the beginning of the queue, process all of them let processReads [] = pure [] @@ -40,7 +48,7 @@ handlePutMVar_ValueEmptyCase m mvd@MVarDescriptor{..} v = do case tsStatus of ThreadBlocked (BlockedOnMVarRead _) -> do updateThreadState tid (ts {tsStatus = ThreadRunning, tsCurrentResult = [v]}) - --liftIO $ putStrLn $ " * (handlePutMVar_ValueEmptyCase, processReads) mvar unblock, unblocked tid: " ++ show tid + --liftIO $ putStrLn $ " * (handlePutMVarValueEmptyCase, processReads) mvar unblock, unblocked tid: " ++ show tid processReads tidTail _ -> pure tids @@ -65,7 +73,7 @@ handlePutMVar_ValueEmptyCase m mvd@MVarDescriptor{..} v = do -- Q: what if the thread was killed by now? -- A: killed threads are always removed from waiting queues - --liftIO $ putStrLn $ " * (handlePutMVar_ValueEmptyCase) mvar unblock, unblocked tid: " ++ show tid + --liftIO $ putStrLn $ " * (handlePutMVarValueEmptyCase) mvar unblock, unblocked tid: " ++ show tid -- update wait queue let newValue = mvd {mvdQueue = tidTail} @@ -77,7 +85,7 @@ appendMVarQueue m tid = do modify' $ \s@StgState{..} -> s {ssMVars = IntMap.adjust appendFun m ssMVars} reportOp :: Name -> [Atom] -> M () -reportOp op args = do +reportOp _op _args = do {- tid <- gets ssCurrentThreadId liftIO $ do @@ -118,7 +126,7 @@ evalPrimOp fallback op args t tc = case (op, args) of pure [] -- NOTE: the real return value will be calculated when the tread is unblocked Just a -> do - handleTakeMVar_ValueFullCase m mvd + handleTakeMVarValueFullCase m mvd pure [a] -- tryTakeMVar# :: MVar# s a -> State# s -> (# State# s, Int#, a #) @@ -130,7 +138,7 @@ evalPrimOp fallback op args t tc = case (op, args) of Nothing -> do pure [IntV 0, LiftedUndefined] Just a -> do - handleTakeMVar_ValueFullCase m mvd + handleTakeMVarValueFullCase m mvd pure [IntV 1, a] -- putMVar# :: MVar# s a -> a -> State# s -> State# s @@ -155,7 +163,7 @@ evalPrimOp fallback op args t tc = case (op, args) of pure [] Nothing -> do - handlePutMVar_ValueEmptyCase m mvd a + handlePutMVarValueEmptyCase m mvd a pure [] -- tryPutMVar# :: MVar# s a -> a -> State# s -> (# State# s, Int# #) @@ -165,7 +173,7 @@ evalPrimOp fallback op args t tc = case (op, args) of --liftIO $ putStrLn $ "mvdValue: " ++ show mvdValue case mvdValue of Nothing -> do - handlePutMVar_ValueEmptyCase m mvd a + handlePutMVarValueEmptyCase m mvd a pure [IntV 1] Just _ -> do pure [IntV 0] @@ -173,7 +181,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- readMVar# :: MVar# s a -> State# s -> (# State# s, a #) ( "readMVar#", [MVar m, _s]) -> do reportOp op args - mvd@MVarDescriptor{..} <- lookupMVar m + MVarDescriptor{..} <- lookupMVar m --liftIO $ putStrLn $ "mvdValue: " ++ show mvdValue case mvdValue of Nothing -> do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MiscEtc.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MiscEtc.hs index 267daac..d0ad9b6 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MiscEtc.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MiscEtc.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.MiscEtc where -import Control.Monad.State -import Foreign.C -import Foreign.Ptr +import Control.Applicative (Applicative (..)) +import Control.Monad.State (MonadIO (..), gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base -import Stg.Interpreter.Debugger.Region (evalRegionCommand) +import Data.Function (($)) +import Data.Maybe (Maybe) -pattern Int64V i = IntAtom i +import Foreign.C (peekCString) +import Foreign.Ptr (castPtr, nullPtr) + +import Stg.Interpreter.Base +import Stg.Interpreter.Debugger.Region (evalRegionCommand) +import Stg.Syntax (Name, TyCon, Type) + +import System.IO (print) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -47,7 +51,7 @@ evalPrimOp fallback op args t tc = case (op, args) of pure [] -- setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld - ( "setThreadAllocationCounter#", [Int64V n, _s]) -> do + ( "setThreadAllocationCounter#", [Int64V _n, _s]) -> do -- TODO pure [] @@ -193,4 +197,4 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp with has_side_effects = True out_of_line = True --} \ No newline at end of file +-} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MutVar.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MutVar.hs index 54fe0ec..d5f4f94 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MutVar.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MutVar.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Stg.Interpreter.PrimOp.MutVar where -import Control.Monad.State -import qualified Data.IntMap as IntMap +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad.State (gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Eq (Eq (..)) +import Data.Function (($)) +import qualified Data.IntMap as IntMap +import Data.Maybe (Maybe) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Narrowings.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Narrowings.hs index 209469a..d558e1e 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Narrowings.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Narrowings.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} module Stg.Interpreter.PrimOp.Narrowings where -import Data.Int -import Data.Word +import Control.Applicative (Applicative (..)) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Function (($)) +import Data.Int (Int16, Int32, Int8) +import Data.Maybe (Maybe) +import Data.Word (Word16, Word32, Word8) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Real (fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -32,4 +33,4 @@ evalPrimOp fallback op args t tc = case (op, args) of -- narrow32Word# :: Word# -> Word# ( "narrow32Word#", [WordV a]) -> pure [WordV $ fromIntegral (fromIntegral a :: Word32)] - _ -> fallback op args t tc + _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ObjectLifetime.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ObjectLifetime.hs index f9acd8b..c45af72 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ObjectLifetime.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ObjectLifetime.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.ObjectLifetime where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) + +import Data.Function (($)) +import Data.Maybe (Maybe) + +import Stg.Interpreter.Base (Atom (..), M, PrimOpEval, StackContinuation (..), stackPush) +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Parallelism.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Parallelism.hs index 856d7a5..f1e7e90 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Parallelism.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Parallelism.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.Parallelism where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) + +import Data.Function (($)) +import Data.Maybe (Maybe) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) {- NOTE: @@ -11,8 +15,6 @@ import Stg.Interpreter.Base - the ext-stg interpreter is a single core evaluator -} -pattern IntV i = IntAtom i - evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Prefetch.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Prefetch.hs index bd9424b..79605ce 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Prefetch.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Prefetch.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.PrimOp.Prefetch where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) + +import Data.Maybe (Maybe) + +import Stg.Interpreter.Base (Atom, M, PrimOpEval) +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -10,57 +13,57 @@ evalPrimOp fallback op args t tc = case (op, args) of -- level 3 -- prefetchByteArray3# :: ByteArray# -> Int# -> State# s -> State# s - ( "prefetchByteArray3#", [_ba, _i, _s]) -> pure [] + ( "prefetchByteArray3#", [_ba, _i, _s]) -> pure [] -- prefetchMutableByteArray3# :: MutableByteArray# s -> Int# -> State# s -> State# s ( "prefetchMutableByteArray3#", [_ba, _i, _s]) -> pure [] -- prefetchAddr3# :: Addr# -> Int# -> State# s -> State# s - ( "prefetchAddr3#", [_a, _i, _s]) -> pure [] + ( "prefetchAddr3#", [_a, _i, _s]) -> pure [] -- prefetchValue3# :: a -> State# s -> State# s - ( "prefetchValue3#", [_v, _s]) -> pure [] + ( "prefetchValue3#", [_v, _s]) -> pure [] -- level 2 -- prefetchByteArray2# :: ByteArray# -> Int# -> State# s -> State# s - ( "prefetchByteArray2#", [_ba, _i, _s]) -> pure [] + ( "prefetchByteArray2#", [_ba, _i, _s]) -> pure [] -- prefetchMutableByteArray2# :: MutableByteArray# s -> Int# -> State# s -> State# s ( "prefetchMutableByteArray2#", [_ba, _i, _s]) -> pure [] -- prefetchAddr2# :: Addr# -> Int# -> State# s -> State# s - ( "prefetchAddr2#", [_a, _i, _s]) -> pure [] + ( "prefetchAddr2#", [_a, _i, _s]) -> pure [] -- prefetchValue2# :: a -> State# s -> State# s - ( "prefetchValue2#", [_v, _s]) -> pure [] + ( "prefetchValue2#", [_v, _s]) -> pure [] -- level 1 -- prefetchByteArray1# :: ByteArray# -> Int# -> State# s -> State# s - ( "prefetchByteArray1#", [_ba, _i, _s]) -> pure [] + ( "prefetchByteArray1#", [_ba, _i, _s]) -> pure [] -- prefetchMutableByteArray1# :: MutableByteArray# s -> Int# -> State# s -> State# s ( "prefetchMutableByteArray1#", [_ba, _i, _s]) -> pure [] -- prefetchAddr1# :: Addr# -> Int# -> State# s -> State# s - ( "prefetchAddr1#", [_a, _i, _s]) -> pure [] + ( "prefetchAddr1#", [_a, _i, _s]) -> pure [] -- prefetchValue1# :: a -> State# s -> State# s - ( "prefetchValue1#", [_v, _s]) -> pure [] + ( "prefetchValue1#", [_v, _s]) -> pure [] -- level 0 -- prefetchByteArray0# :: ByteArray# -> Int# -> State# s -> State# s - ( "prefetchByteArray0#", [_ba, _i, _s]) -> pure [] + ( "prefetchByteArray0#", [_ba, _i, _s]) -> pure [] -- prefetchMutableByteArray0# :: MutableByteArray# s -> Int# -> State# s -> State# s ( "prefetchMutableByteArray0#", [_ba, _i, _s]) -> pure [] -- prefetchAddr0# :: Addr# -> Int# -> State# s -> State# s - ( "prefetchAddr0#", [_a, _i, _s]) -> pure [] + ( "prefetchAddr0#", [_a, _i, _s]) -> pure [] -- prefetchValue0# :: a -> State# s -> State# s - ( "prefetchValue0#", [_v, _s]) -> pure [] + ( "prefetchValue0#", [_v, _s]) -> pure [] - _ -> fallback op args t tc + _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/STM.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/STM.hs index a2b4882..1332a43 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/STM.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/STM.hs @@ -1,20 +1,34 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} module Stg.Interpreter.PrimOp.STM where -import GHC.Stack -import Control.Monad.State -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Monad (..), forM_, mapM, when) +import Control.Monad.State (gets, modify') -import Text.Pretty.Simple (pShowNoColor) -import qualified Data.Text.Lazy.IO as Text -import Data.Maybe +import Data.Bool (Bool (..), not) +import Data.Eq (Eq (..)) +import Data.Function (const, ($)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.List (and, drop, (++)) +import Data.Maybe (Maybe (..), fromJust, maybeToList) +import Data.Monoid (Monoid (..)) -import Stg.Syntax -import Stg.Interpreter.Base -import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency +import GHC.Err (error, undefined) +import GHC.Stack (HasCallStack) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base (Atom (..), BlockReason (..), M, PrimOpEval, Rts (..), ScheduleReason (..), + StackContinuation (..), StgState (..), TLog, TLogEntry (..), TVarDescriptor (..), + ThreadState (..), ThreadStatus (..), getCurrentThreadState, getThreadState, + lookupTVar, promptM, reportThread, stackPop, stackPush, subscribeTVarWaitQueues, + unsubscribeTVarWaitQueues, updateThreadState, validateTLog) +import Stg.Syntax (Name, TyCon, Type) + +import System.IO (print, putStrLn) + +import Text.Show (Show (..)) {- STM design notes @@ -46,7 +60,7 @@ TODO: - read paper from 6.1 transaction logs Q: is there a new tlog entry for each tvar operation or is it one entry per tvar? -A: +A: Q: what is the difference between STM and SQL transactions? is it the value sampling? @@ -83,7 +97,7 @@ evalPrimOp fallback op args t tc = case (op, args) of print (op, args) tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlog = tsActiveTLog ts + let tlog = fromJust $ tsActiveTLog ts -- push tlog, start fresh active tlog for the nested transaction updateThreadState tid $ ts {tsActiveTLog = Just mempty, tsTLogStack = tlog : tsTLogStack ts} stackPush $ CatchRetry firstStmAction altStmAction False mempty @@ -99,7 +113,7 @@ evalPrimOp fallback op args t tc = case (op, args) of print (op, args) tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlog = tsActiveTLog ts + let tlog = fromJust $ tsActiveTLog ts -- push tlog, start fresh active tlog for the nested transaction updateThreadState tid $ ts {tsActiveTLog = Just mempty, tsTLogStack = tlog : tsTLogStack ts} stackPush $ CatchSTM f h @@ -118,18 +132,18 @@ evalPrimOp fallback op args t tc = case (op, args) of -- DONE -- readTVar# :: TVar# s a -> State# s -> (# State# s, a #) - ( "readTVar#", [TVar t, _s]) -> do + ( "readTVar#", [TVar t', _s]) -> do promptM $ print (op, args) -- read from TLog tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlogEntryMap = tsActiveTLog ts - tlogStack = tsTLogStack ts - case IntMap.lookup t tlogEntryMap of + let tlogEntryMap = fromJust $ tsActiveTLog ts + tlogStack = tsTLogStack ts + case IntMap.lookup t' tlogEntryMap of Nothing -> do -- HINT: first access - entry@TLogEntry{..} <- getTLogEntry tlogStack t - let extendedTLog = IntMap.insert t entry tlogEntryMap + entry@TLogEntry{..} <- getTLogEntry tlogStack t' + let extendedTLog = IntMap.insert t' entry tlogEntryMap updateThreadState tid $ ts {tsActiveTLog = Just extendedTLog} pure [tleCurrentLocalValue] Just TLogEntry{..} -> do @@ -137,31 +151,31 @@ evalPrimOp fallback op args t tc = case (op, args) of -- DONE -- readTVarIO# :: TVar# s a -> State# s -> (# State# s, a #) - ( "readTVarIO#", [TVar t, _s]) -> do + ( "readTVarIO#", [TVar t', _s]) -> do promptM $ print (op, args) - a <- tvdValue <$> lookupTVar t + a <- tvdValue <$> lookupTVar t' pure [a] -- DONE -- writeTVar# :: TVar# s a -> a -> State# s -> State# s - ( "writeTVar#", [TVar t, value, _s]) -> do + ( "writeTVar#", [TVar t', value, _s]) -> do promptM $ print (op, args) -- write to TLog tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlogEntryMap = tsActiveTLog ts - tlogStack = tsTLogStack ts - case IntMap.lookup t tlogEntryMap of + let tlogEntryMap = fromJust $ tsActiveTLog ts + tlogStack = tsTLogStack ts + case IntMap.lookup t' tlogEntryMap of Nothing -> do -- HINT: first access - entry <- getTLogEntry tlogStack t + entry <- getTLogEntry tlogStack t' let newEntry = entry {tleCurrentLocalValue = value} - extendedTLog = IntMap.insert t newEntry tlogEntryMap + extendedTLog = IntMap.insert t' newEntry tlogEntryMap updateThreadState tid $ ts {tsActiveTLog = Just extendedTLog} pure [] Just oldEntry -> do let newEntry = oldEntry {tleCurrentLocalValue = value} - let updatedTLog = IntMap.insert t newEntry tlogEntryMap + let updatedTLog = IntMap.insert t' newEntry tlogEntryMap updateThreadState tid $ ts {tsActiveTLog = Just updatedTLog} pure [] @@ -198,20 +212,23 @@ getTLogEntry [] tvarId = do , tleCurrentLocalValue = globalValue } getTLogEntry (tlog : tlogStack) tvarId = case IntMap.lookup tvarId tlog of - Nothing -> getTLogEntry tlogStack tvarId - Just entry -> pure entry + Nothing -> getTLogEntry tlogStack tvarId + Just entry -> pure entry -- read: stg_catch_stm_frame mergeNestedOrRestart :: HasCallStack => [Atom] -> M [Atom] mergeNestedOrRestart result = do tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlog = tsActiveTLog ts - tlogStack@(tlogStackTop : tlogStackTail) = tsTLogStack ts + let tlog = fromJust $ tsActiveTLog ts + (tlogStackTop, tlogStackTail) = + case tsTLogStack ts of + [] -> undefined + (a : b) -> (a, b) + tlogStack = tlogStackTop : tlogStackTail -- validate every tlog allValid <- and <$> mapM validateTLog (tlog : tlogStack) - case allValid of - False -> do + if allValid then do -- drop current transaction updateThreadState tid $ ts { tsActiveTLog = Just tlogStackTop @@ -219,7 +236,7 @@ mergeNestedOrRestart result = do } -- restart the whole transaction restartSTMFromAtomicallyFrame - True -> do + else do -- merge nested let mergedTLog = IntMap.unionWith (\a _ -> a) tlog tlogStackTop updateThreadState tid $ ts @@ -247,14 +264,14 @@ restartSTMFromAtomicallyFrame = unwindStack where -- HINT: pop tlog stack for some extra stg state consistency and validation ts <- getCurrentThreadState tid <- gets ssCurrentThreadId - updateThreadState tid $ ts {tsTLogStack = tail $ tsTLogStack ts} + updateThreadState tid $ ts {tsTLogStack = drop 1 $ tsTLogStack ts} unwindStack Just CatchRetry{} -> do -- HINT: pop tlog stack for some extra stg state consistency and validation ts <- getCurrentThreadState tid <- gets ssCurrentThreadId - updateThreadState tid $ ts {tsTLogStack = tail $ tsTLogStack ts} + updateThreadState tid $ ts {tsTLogStack = drop 1 $ tsTLogStack ts} unwindStack _ -> unwindStack -- HINT: discard stack frames @@ -293,10 +310,14 @@ retrySTM = unwindStack where Just CatchSTM{} -> do ts <- getCurrentThreadState tid <- gets ssCurrentThreadId + let (tlogStackTop, tlogStackTail) = + case tsTLogStack ts of + [] -> undefined + (a : b) -> (a, b) -- HINT: pop tlog stack, merge the old stack top to the active tlog (it is needed for TVar subscription on STM suspend) updateThreadState tid $ ts - { tsTLogStack = tail $ tsTLogStack ts - , tsActiveTLog = Just $ IntMap.unionsWith (\a _ -> a) $ maybeToList (tsActiveTLog ts) ++ [head $ tsTLogStack ts] + { tsTLogStack = tlogStackTail + , tsActiveTLog = Just $ IntMap.unionsWith const $ maybeToList (tsActiveTLog ts) ++ [tlogStackTop] } unwindStack @@ -306,9 +327,13 @@ retrySTM = unwindStack where Just (CatchRetry _firstStmAction _altStmAction True firstTLog) -> do ts <- getCurrentThreadState tid <- gets ssCurrentThreadId + let (tlogStackTop, tlogStackTail) = + case tsTLogStack ts of + [] -> undefined + (a : b) -> (a, b) updateThreadState tid $ ts - { tsTLogStack = tail $ tsTLogStack ts - , tsActiveTLog = Just $ IntMap.unionsWith (\a _ -> a) $ maybeToList (tsActiveTLog ts) ++ [head $ tsTLogStack ts, firstTLog] + { tsTLogStack = tlogStackTail + , tsActiveTLog = Just $ IntMap.unionsWith const $ maybeToList (tsActiveTLog ts) ++ [tlogStackTop, firstTLog] } unwindStack @@ -325,7 +350,7 @@ retrySTM = unwindStack where Just (Atomically stmAction) -> do tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlog = tsActiveTLog ts + let tlog = fromJust $ tsActiveTLog ts -- extra validation (optional) when (tsTLogStack ts /= []) $ error "internal error: non-empty tsTLogStack without tsActiveTLog" @@ -336,18 +361,18 @@ retrySTM = unwindStack where putStrLn $ "[STM] tid: " ++ show tid ++ " tlog: " ++ show tlog putStrLn $ "[STM] validateTLog: " ++ show isValid - if (not isValid) + if not isValid then do restartTransaction stmAction else do promptM $ putStrLn $ "[STM] retry, block thread, tid: " ++ show tid - tid <- gets ssCurrentThreadId - ts <- getThreadState tid + tid' <- gets ssCurrentThreadId + ts' <- getThreadState tid' -- subscribe to wait queues - let Just tlog = tsActiveTLog ts - subscribeTVarWaitQueues tid tlog -- HINT: GC deadlock detection will cover empty tlog and dead TVar caused deadlocks + let tlog' = fromJust $ tsActiveTLog ts' + subscribeTVarWaitQueues tid' tlog -- HINT: GC deadlock detection will cover empty tlog and dead TVar caused deadlocks -- suspend thread - updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnSTM tlog), tsActiveTLog = Just mempty}) + updateThreadState tid' (ts' {tsStatus = ThreadBlocked (BlockedOnSTM tlog'), tsActiveTLog = Just mempty}) -- Q: who will update the tsTLog after the wake up? stackPush $ Atomically stmAction stackPush $ Apply [Void] @@ -369,7 +394,7 @@ commitOrRestart :: HasCallStack => Atom -> [Atom] -> M [Atom] commitOrRestart stmAction result = do tid <- gets ssCurrentThreadId ts <- getThreadState tid - let Just tlog = tsActiveTLog ts + let tlog = fromJust $ tsActiveTLog ts -- extra validation (optional) when (tsTLogStack ts /= []) $ error "internal error: non-empty tsTLogStack without tsActiveTLog" -- validate @@ -512,4 +537,4 @@ primop WriteTVarOp "writeTVar#" GenPrimOp primop SameTVarOp "sameTVar#" GenPrimOp TVar# s a -> TVar# s a -> Int# --} \ No newline at end of file +-} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/SmallArray.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/SmallArray.hs index 57a865f..e2c1464 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/SmallArray.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/SmallArray.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.SmallArray where -import Control.Monad.State -import qualified Data.IntMap as IntMap -import qualified Data.Vector as V +import Control.Applicative (Applicative (..)) +import Control.Monad.State (MonadState (..), gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Eq (Eq (..)) +import Data.Function (($)) +import qualified Data.IntMap as IntMap +import Data.Maybe (Maybe) +import qualified Data.Vector as V -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) lookupSmallArrIdx :: SmallArrIdx -> M (V.Vector Atom) lookupSmallArrIdx = \case @@ -28,49 +32,49 @@ evalPrimOp fallback op args t tc = case (op, args) of -- newSmallArray# :: Int# -> a -> State# s -> (# State# s, SmallMutableArray# s a #) ( "newSmallArray#", [IntV i, a, _s]) -> do - smallMutableArrays <- gets ssSmallMutableArrays + _smallMutableArrays <- gets ssSmallMutableArrays next <- gets ssNextSmallMutableArray - let v = V.replicate (fromIntegral i) a + let v = V.replicate i a modify' $ \s@StgState{..} -> s {ssSmallMutableArrays = IntMap.insert next v ssSmallMutableArrays, ssNextSmallMutableArray = succ next} pure [SmallMutableArray $ SmallMutArrIdx next] -- shrinkSmallMutableArray# :: SmallMutableArray# s a -> Int# -> State# s -> State# s ( "shrinkSmallMutableArray#",[SmallMutableArray src,IntV n,_s]) -> do v <- lookupSmallArrIdx src - updateSmallArrIdx src $ V.slice 0 (fromIntegral n) v + updateSmallArrIdx src $ V.slice 0 n v pure [] -- readSmallArray# :: SmallMutableArray# s a -> Int# -> State# s -> (# State# s, a #) ( "readSmallArray#", [SmallMutableArray a, IntV i, _s]) -> do v <- lookupSmallArrIdx a - pure [v V.! (fromIntegral i)] + pure [v V.! i] -- writeSmallArray#" :: SmallMutableArray# s a -> Int# -> a -> State# s -> State# s ( "writeSmallArray#", [SmallMutableArray m, IntV i, a, _s]) -> do v <- lookupSmallArrIdx m - updateSmallArrIdx m (v V.// [(fromIntegral i, a)]) + updateSmallArrIdx m (v V.// [(i, a)]) pure [] -- sizeofSmallArray# :: SmallArray# a -> Int# ( "sizeofSmallArray#", [SmallArray a]) -> do v <- lookupSmallArrIdx a - pure [IntV . fromIntegral $ V.length v] + pure [IntV $ V.length v] -- sizeofSmallMutableArray# :: SmallMutableArray# s a -> Int# ( "sizeofSmallMutableArray#", [SmallMutableArray a]) -> do -- DEPRECATED: Use 'getSizeofSmallMutableArray#' instead v <- lookupSmallArrIdx a - pure [IntV . fromIntegral $ V.length v] + pure [IntV $ V.length v] -- getSizeofSmallMutableArray# :: SmallMutableArray# s a -> State# s -> (# State# s, Int# #) ( "getSizeofSmallMutableArray#", [SmallMutableArray a, _s]) -> do v <- lookupSmallArrIdx a - pure [IntV . fromIntegral $ V.length v] + pure [IntV $ V.length v] -- indexSmallArray# :: SmallArray# a -> Int# -> (# a #) ( "indexSmallArray#", [SmallArray a, IntV i]) -> do v <- lookupSmallArrIdx a - pure [v V.! (fromIntegral i)] + pure [v V.! i] -- unsafeFreezeSmallArray# :: SmallMutableArray# s a -> State# s -> (# State# s, SmallArray# a #) ( "unsafeFreezeSmallArray#", [SmallMutableArray v, _s]) -> do @@ -84,11 +88,11 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "copySmallArray#", [SmallArray src, IntV os, SmallMutableArray dst, IntV od, IntV n, _s]) -> do vsrc <- lookupSmallArrIdx src vdst <- lookupSmallArrIdx dst - let vdst' = vdst V.// [ (fromIntegral di, v) + let vdst' = vdst V.// [ (di, v) | i <- [ 0 .. n-1 ] , let si = os + i , let di = od + i - , let v = vsrc V.! (fromIntegral si) + , let v = vsrc V.! si ] updateSmallArrIdx dst vdst' pure [] @@ -97,11 +101,11 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "copySmallMutableArray#", [SmallMutableArray src, IntV os, SmallMutableArray dst, IntV od, IntV n, _s]) -> do vsrc <- lookupSmallArrIdx src vdst <- lookupSmallArrIdx dst - let vdst' = vdst V.// [ (fromIntegral di, v) + let vdst' = vdst V.// [ (di, v) | i <- [ 0 .. n-1 ] , let si = os + i , let di = od + i - , let v = vsrc V.! (fromIntegral si) + , let v = vsrc V.! si ] updateSmallArrIdx dst vdst' pure [] @@ -109,7 +113,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- cloneSmallArray# :: SmallArray# a -> Int# -> Int# -> SmallArray# a ( "cloneSmallArray#", [SmallArray src, IntV o, IntV n]) -> do vsrc <- lookupSmallArrIdx src - let vdst = V.slice (fromIntegral o) (fromIntegral n) vsrc + let vdst = V.slice o n vsrc state $ \s'@StgState{..} -> let next = ssNextSmallArray in ([SmallArray $ SmallArrIdx next], s' {ssSmallArrays = IntMap.insert next vdst ssSmallArrays, ssNextSmallArray = succ next}) @@ -117,7 +121,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- cloneSmallMutableArray# :: SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #) ( "cloneSmallMutableArray#", [SmallMutableArray src, IntV o, IntV n, _s]) -> do vsrc <- lookupSmallArrIdx src - let vdst = V.slice (fromIntegral o) (fromIntegral n) vsrc + let vdst = V.slice o n vsrc state $ \s'@StgState{..} -> let next = ssNextSmallMutableArray in ([SmallMutableArray $ SmallMutArrIdx next], s' {ssSmallMutableArrays = IntMap.insert next vdst ssSmallMutableArrays, ssNextSmallMutableArray = succ next}) @@ -125,7 +129,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- freezeSmallArray# :: SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a #) ( "freezeSmallArray#", [SmallMutableArray src, IntV o, IntV n, _s]) -> do vsrc <- lookupSmallArrIdx src - let vdst = V.slice (fromIntegral o) (fromIntegral n) vsrc + let vdst = V.slice o n vsrc state $ \s'@StgState{..} -> let next = ssNextSmallArray in ([SmallArray $ SmallArrIdx next], s' {ssSmallArrays = IntMap.insert next vdst ssSmallArrays, ssNextSmallArray = next}) @@ -133,7 +137,7 @@ evalPrimOp fallback op args t tc = case (op, args) of -- thawSmallArray# :: SmallArray# a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #) ( "thawSmallArray#", [SmallArray src, IntV o, IntV n, _s]) -> do vsrc <- lookupSmallArrIdx src - let vdst = V.slice (fromIntegral o) (fromIntegral n) vsrc + let vdst = V.slice o n vsrc state $ \s'@StgState{..} -> let next = ssNextSmallMutableArray in ([SmallMutableArray $ SmallMutArrIdx next], s' {ssSmallMutableArrays = IntMap.insert next vdst ssSmallMutableArrays, ssNextSmallMutableArray = succ next}) @@ -142,10 +146,10 @@ evalPrimOp fallback op args t tc = case (op, args) of -- NOTE: CPU atomic ( "casSmallArray#", [SmallMutableArray src, IntV o, old, new, _s]) -> do vsrc <- lookupSmallArrIdx src - let current = vsrc V.! (fromIntegral o) + let current = vsrc V.! o if current == old then do - updateSmallArrIdx src (vsrc V.// [(fromIntegral o, new)]) + updateSmallArrIdx src (vsrc V.// [(o, new)]) pure [IntV 0, new] else do pure [IntV 1, current] diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/StablePointer.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/StablePointer.hs index 9b0525e..d1b6eda 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/StablePointer.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/StablePointer.hs @@ -1,15 +1,20 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.StablePointer where -import Foreign.Ptr -import Control.Monad.State -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad.State (gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) +import Foreign.Ptr (IntPtr (..), intPtrToPtr) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/TagToEnum.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/TagToEnum.hs index ca4c01c..9c52c33 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/TagToEnum.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/TagToEnum.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.TagToEnum where -import Data.List (findIndex) -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.List (findIndex, (!!), (++)) +import Data.Maybe (Maybe (..)) + +import Stg.Interpreter.Base +import Stg.Syntax (CutTyCon (..), DC (..), DataCon (..), Name, TyCon (..), Type) + +import Text.Show (Show (..)) dataToTagOp :: [Atom] -> M [Atom] dataToTagOp [whnf@HeapPtr{}] = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Unsafe.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Unsafe.hs index 2109e2c..1e62aac 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Unsafe.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Unsafe.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.Unsafe where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -55,4 +58,4 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp -- The trouble is that pointer equality between thunks is very different -- from pointer equality between the values those thunks reduce to, and the latter -- is typically much more precise. --} \ No newline at end of file +-} diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/WeakPointer.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/WeakPointer.hs index 864f2c1..a1446d9 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/WeakPointer.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/WeakPointer.hs @@ -1,16 +1,27 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} module Stg.Interpreter.PrimOp.WeakPointer where -import Control.Monad.State -import qualified Data.IntMap as IntMap -import Data.Maybe -import Foreign.Ptr +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (mapM, mapM_, void) +import Control.Monad.State (gets, modify') -import Stg.Syntax -import Stg.Interpreter.Base -import qualified Stg.Interpreter.FFI as FFI +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List ((++)) +import Data.Maybe (Maybe (..), catMaybes, isNothing, maybeToList) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) +import Foreign.Ptr (castPtrToFunPtr) + +import GHC.Err (error) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import qualified Stg.Interpreter.FFI as FFI +import Stg.Syntax (Name, TyCon, Type (..)) + +import Text.Show (Show (..)) newWeakPointer :: Atom -> Atom -> Maybe Atom -> M Int newWeakPointer key value finalizer = do @@ -44,7 +55,7 @@ evalPrimOp fallback op args t tc = case (op, args) of wpd@WeakPtrDescriptor{..} <- lookupWeakPointerDescriptor wpId let desc = wpd {wpdCFinalizers = (fun, if hasEnv == 0 then Nothing else Just envPtr, dataPtr) : wpdCFinalizers} modify' $ \s@StgState{..} -> s {ssWeakPointers = IntMap.insert wpId desc ssWeakPointers} - pure [IntV $ if wpdValue == Nothing then 0 else 1] + pure [IntV $ if isNothing wpdValue then 0 else 1] -- deRefWeak# :: Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, a #) ( "deRefWeak#", [WeakPointer wpId, _w]) -> do @@ -69,7 +80,7 @@ finalizeWeak wpId = do wpd@WeakPtrDescriptor{..} <- lookupWeakPointerDescriptor wpId case wpdValue of Nothing -> pure [IntV 0, LiftedUndefined] - Just v -> do + Just _v -> do let finalizedWpd = wpd {wpdValue = Nothing} modify' $ \s@StgState{..} -> s {ssWeakPointers = IntMap.insert wpId finalizedWpd ssWeakPointers} mapM_ runCFinalizer wpdCFinalizers @@ -80,8 +91,7 @@ finalizeWeak wpId = do runCFinalizer :: (Atom, Maybe Atom, Atom) -> M () runCFinalizer (PtrAtom _ cFunPtr, mCEnv, cData) = do cArgs <- catMaybes <$> mapM FFI.mkFFIArg (maybeToList mCEnv ++ [cData]) - liftIOAndBorrowStgState $ do + void $ liftIOAndBorrowStgState $ do let cRetType = UnboxedTuple [] FFI.evalForeignCall (castPtrToFunPtr cFunPtr) cArgs cRetType - pure () runCFinalizer f = error $ "unsupported weakptr c finalizer: " ++ show f diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word.hs index e98aa03..f7e1d16 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word.hs @@ -1,20 +1,29 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, TypeApplications, Strict #-} -{-# LANGUAGE ScopedTypeVariables, MagicHash #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Strict #-} module Stg.Interpreter.PrimOp.Word where -import Data.Word -import Data.Bits -import GHC.Exts -import GHC.Word +import Control.Applicative (Applicative (..)) -import Stg.Syntax -import Stg.Interpreter.Base +import Data.Bits (Bits (..), FiniteBits (..), testBitDefault) +import Data.Bool ((||)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.List (foldl) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word16, Word32, Word64, Word8, byteSwap16, byteSwap32, byteSwap64) -type PrimWord = Word64 +import GHC.Exts +import GHC.Num (Integer, Num (..)) +import GHC.Real (Integral (..), fromIntegral) +import GHC.Word (Word64 (..)) + +import Prelude (Bounded (..)) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) + +type PrimWord = Word64 evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = case (op, args) of @@ -122,34 +131,34 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "popCnt#", [WordV a]) -> pure [WordV . fromIntegral $ popCount a] -- pdep8# :: Word# -> Word# -> Word# - ( "pdep8#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pdep8 (fromIntegral a) (fromIntegral b)] + ( "pdep8#", [WordV a, WordV b]) -> pure [WordV $ pdep8 a b] -- pdep16# :: Word# -> Word# -> Word# - ( "pdep16#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pdep16 (fromIntegral a) (fromIntegral b)] + ( "pdep16#", [WordV a, WordV b]) -> pure [WordV $ pdep16 a b] -- pdep32# :: Word# -> Word# -> Word# - ( "pdep32#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pdep32 (fromIntegral a) (fromIntegral b)] + ( "pdep32#", [WordV a, WordV b]) -> pure [WordV $ pdep32 a b] -- pdep64# :: Word64# -> Word64# -> Word64# ( "pdep64#", [Word64V a, Word64V b]) -> pure [Word64V $ fromIntegral $ pdep64 (fromIntegral a) (fromIntegral b)] -- pdep# :: Word# -> Word# -> Word# - ( "pdep#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pdep (fromIntegral a) (fromIntegral b)] + ( "pdep#", [WordV a, WordV b]) -> pure [WordV $ pdep a b] -- pext8# :: Word# -> Word# -> Word# - ( "pext8#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pext8 (fromIntegral a) (fromIntegral b)] + ( "pext8#", [WordV a, WordV b]) -> pure [WordV $ pext8 a b] -- pext16# :: Word# -> Word# -> Word# - ( "pext16#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pext16 (fromIntegral a) (fromIntegral b)] + ( "pext16#", [WordV a, WordV b]) -> pure [WordV $ pext16 a b] -- pext32# :: Word# -> Word# -> Word# - ( "pext32#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pext32 (fromIntegral a) (fromIntegral b)] + ( "pext32#", [WordV a, WordV b]) -> pure [WordV $ pext32 a b] -- pext64# :: Word64# -> Word64# -> Word64# ( "pext64#", [Word64V a, Word64V b]) -> pure [Word64V $ fromIntegral $ pext64 (fromIntegral a) (fromIntegral b)] -- pext# :: Word# -> Word# -> Word# - ( "pext#", [WordV a, WordV b]) -> pure [WordV $ fromIntegral $ pext (fromIntegral a) (fromIntegral b)] + ( "pext#", [WordV a, WordV b]) -> pure [WordV $ pext a b] -- clz8# :: Word# -> Word# ( "clz8#", [WordV a]) -> pure [WordV . fromIntegral $ countLeadingZeros (fromIntegral a :: Word8)] @@ -164,7 +173,7 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "clz64#", [Word64V a]) -> pure [WordV . fromIntegral $ countLeadingZeros (fromIntegral a :: Word64)] -- clz# :: Word# -> Word# - ( "clz#", [WordV a]) -> pure [WordV . fromIntegral $ countLeadingZeros (fromIntegral a :: Word)] + ( "clz#", [WordV a]) -> pure [WordV . fromIntegral $ countLeadingZeros (a :: Word)] -- ctz8# :: Word# -> Word# ( "ctz8#", [WordV a]) -> pure [WordV . fromIntegral $ countTrailingZeros (fromIntegral a :: Word8)] @@ -179,7 +188,7 @@ evalPrimOp fallback op args t tc = case (op, args) of ( "ctz64#", [Word64V a]) -> pure [WordV . fromIntegral $ countTrailingZeros (fromIntegral a :: Word64)] -- ctz# :: Word# -> Word# - ( "ctz#", [WordV a]) -> pure [WordV . fromIntegral $ countTrailingZeros (fromIntegral a :: Word)] + ( "ctz#", [WordV a]) -> pure [WordV . fromIntegral $ countTrailingZeros (a :: Word)] -- byteSwap16# :: Word# -> Word# ( "byteSwap16#", [WordV a]) -> pure [WordV . fromIntegral $ byteSwap16 (fromIntegral a :: Word16)] diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word16.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word16.hs index af2fc64..a75b1d5 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word16.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word16.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} module Stg.Interpreter.PrimOp.Word16 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Word -import Data.Bits +import Data.Bits (Bits (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word, Word16) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word32.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word32.hs index e973644..53255a3 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word32.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word32.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} module Stg.Interpreter.PrimOp.Word32 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Word -import Data.Bits +import Data.Bits (Bits (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word, Word32) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word64.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word64.hs index bfe418f..4609201 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word64.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word64.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} module Stg.Interpreter.PrimOp.Word64 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Word -import Data.Bits +import Data.Bits (Bits (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word, Word64) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do @@ -20,37 +23,37 @@ evalPrimOp fallback op args t tc = do case (op, args) of -- word64ToWord# :: Word64# -> Word# - ( "word64ToWord#", [Word64V a]) -> pure [WordV a] + ( "word64ToWord#", [Word64V a]) -> pure [WordV a] -- wordToWord64# :: Word# -> Word64# - ( "wordToWord64#", [WordV a]) -> pure [Word64V . w . w64 $ a] + ( "wordToWord64#", [WordV a]) -> pure [Word64V . w . w64 $ a] -- plusWord64# :: Word64# -> Word64# -> Word64# - ( "plusWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a + w64 b] + ( "plusWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a + w64 b] -- subWord64# :: Word64# -> Word64# -> Word64# - ( "subWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a - w64 b] + ( "subWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a - w64 b] -- timesWord64# :: Word64# -> Word64# -> Word64# - ( "timesWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a * w64 b] + ( "timesWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a * w64 b] -- quotWord64# :: Word64# -> Word64# -> Word64# - ( "quotWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `quot` w64 b] -- NOTE: uint64 / uint64 in C + ( "quotWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `quot` w64 b] -- NOTE: uint64 / uint64 in C -- remWord64# :: Word64# -> Word64# -> Word64# - ( "remWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `rem` w64 b] -- NOTE: uint64 % uint64 in C + ( "remWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `rem` w64 b] -- NOTE: uint64 % uint64 in C -- and64# :: Word64# -> Word64# -> Word64# - ( "and64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a .&. w64 b] -- NOTE: uint64 & uint64 in C + ( "and64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a .&. w64 b] -- NOTE: uint64 & uint64 in C -- or64# :: Word64# -> Word64# -> Word64# - ( "or64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a .|. w64 b] -- NOTE: uint64 | uint64 in C + ( "or64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a .|. w64 b] -- NOTE: uint64 | uint64 in C -- xor64# :: Word64# -> Word64# -> Word64# - ( "xor64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `xor` w64 b] -- NOTE: uint64 ^ uint64 in C + ( "xor64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `xor` w64 b] -- NOTE: uint64 ^ uint64 in C -- not64# :: Word64# -> Word64# - ( "not64#", [Word64V a]) -> pure [Word64V . w . complement $ w64 a] + ( "not64#", [Word64V a]) -> pure [Word64V . w . complement $ w64 a] -- uncheckedShiftL64# :: Word64# -> Int# -> Word64# ( "uncheckedShiftL64#", [Word64V a, IntV b]) -> pure [Word64V . w $ unsafeShiftL (w64 a) b] @@ -59,24 +62,24 @@ evalPrimOp fallback op args t tc = do ( "uncheckedShiftRL64#", [Word64V a, IntV b]) -> pure [Word64V . w $ unsafeShiftR (w64 a) b] -- Shift right logical -- word64ToInt64# :: Word64# -> Int64# - ( "word64ToInt64#", [Word64V a]) -> pure [Int64V $ fromIntegral a] + ( "word64ToInt64#", [Word64V a]) -> pure [Int64V $ fromIntegral a] -- eqWord64# :: Word64# -> Word64# -> Int# - ( "eqWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a == b then 1 else 0] + ( "eqWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a == b then 1 else 0] -- geWord64# :: Word64# -> Word64# -> Int# - ( "geWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a >= b then 1 else 0] + ( "geWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a >= b then 1 else 0] -- gtWord64# :: Word64# -> Word64# -> Int# - ( "gtWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a > b then 1 else 0] + ( "gtWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a > b then 1 else 0] -- leWord64# :: Word64# -> Word64# -> Int# - ( "leWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a <= b then 1 else 0] + ( "leWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a <= b then 1 else 0] -- ltWord64# :: Word64# -> Word64# -> Int# - ( "ltWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a < b then 1 else 0] + ( "ltWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a < b then 1 else 0] -- neWord64# :: Word64# -> Word64# -> Int# - ( "neWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a /= b then 1 else 0] + ( "neWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a /= b then 1 else 0] - _ -> fallback op args t tc + _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word8.hs b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word8.hs index 871fa8d..5d4058a 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word8.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word8.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} module Stg.Interpreter.PrimOp.Word8 where -import Stg.Syntax -import Stg.Interpreter.Base +import Control.Applicative (Applicative (..)) -import Data.Word -import Data.Bits +import Data.Bits (Bits (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe) +import Data.Ord (Ord (..)) +import Data.Word (Word, Word8) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) + +import Stg.Interpreter.Base +import Stg.Syntax (Name, TyCon, Type) evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] evalPrimOp fallback op args t tc = do @@ -20,40 +23,40 @@ evalPrimOp fallback op args t tc = do case (op, args) of -- word8ToWord# :: Word8# -> Word# - ( "word8ToWord#", [Word8V a]) -> pure [WordV a] + ( "word8ToWord#", [Word8V a]) -> pure [WordV a] -- wordToWord8# :: Word# -> Word8# - ( "wordToWord8#", [WordV a]) -> pure [Word8V . w . w8 $ a] + ( "wordToWord8#", [WordV a]) -> pure [Word8V . w . w8 $ a] -- plusWord8# :: Word8# -> Word8# -> Word8# - ( "plusWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a + w8 b] + ( "plusWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a + w8 b] -- subWord8# :: Word8# -> Word8# -> Word8# - ( "subWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a - w8 b] + ( "subWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a - w8 b] -- timesWord8# :: Word8# -> Word8# -> Word8# - ( "timesWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a * w8 b] + ( "timesWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a * w8 b] -- quotWord8# :: Word8# -> Word8# -> Word8# - ( "quotWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `quot` w8 b] -- NOTE: uint8 / uint8 in C + ( "quotWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `quot` w8 b] -- NOTE: uint8 / uint8 in C -- remWord8# :: Word8# -> Word8# -> Word8# - ( "remWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `rem` w8 b] -- NOTE: uint8 % uint8 in C + ( "remWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `rem` w8 b] -- NOTE: uint8 % uint8 in C -- quotRemWord8# :: Word8# -> Word8# -> (# Word8#, Word8# #) - ( "quotRemWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `quot` w8 b, Word8V . w $ w8 a `rem` w8 b] + ( "quotRemWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `quot` w8 b, Word8V . w $ w8 a `rem` w8 b] -- andWord8# :: Word8# -> Word8# -> Word8# - ( "andWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a .&. w8 b] -- NOTE: uint8 & uint8 in C + ( "andWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a .&. w8 b] -- NOTE: uint8 & uint8 in C -- orWord8# :: Word8# -> Word8# -> Word8# - ( "orWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a .|. w8 b] -- NOTE: uint8 | uint8 in C + ( "orWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a .|. w8 b] -- NOTE: uint8 | uint8 in C -- xorWord8# :: Word8# -> Word8# -> Word8# - ( "xorWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `xor` w8 b] -- NOTE: uint8 ^ uint8 in C + ( "xorWord8#", [Word8V a, Word8V b]) -> pure [Word8V . w $ w8 a `xor` w8 b] -- NOTE: uint8 ^ uint8 in C -- notWord8# :: Word8# -> Word8# - ( "notWord8#", [Word8V a]) -> pure [Word8V . w . complement $ w8 a] + ( "notWord8#", [Word8V a]) -> pure [Word8V . w . complement $ w8 a] -- uncheckedShiftLWord8# :: Word8# -> Int# -> Word8# ( "uncheckedShiftLWord8#", [Word8V a, IntV b]) -> pure [Word8V . w $ unsafeShiftL (w8 a) b] @@ -62,32 +65,32 @@ evalPrimOp fallback op args t tc = do ( "uncheckedShiftRLWord8#", [Word8V a, IntV b]) -> pure [Word8V . w $ unsafeShiftR (w8 a) b] -- Shift right logical -- word8ToInt8# :: Word8# -> Int8# - ( "word8ToInt8#", [Word8V a]) -> pure [Int8V $ fromIntegral a] + ( "word8ToInt8#", [Word8V a]) -> pure [Int8V $ fromIntegral a] -- eqWord8# :: Word8# -> Word8# -> Int# - ( "eqWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a == b then 1 else 0] + ( "eqWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a == b then 1 else 0] -- geWord8# :: Word8# -> Word8# -> Int# - ( "geWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a >= b then 1 else 0] + ( "geWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a >= b then 1 else 0] -- gtWord8# :: Word8# -> Word8# -> Int# - ( "gtWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a > b then 1 else 0] + ( "gtWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a > b then 1 else 0] -- leWord8# :: Word8# -> Word8# -> Int# - ( "leWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a <= b then 1 else 0] + ( "leWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a <= b then 1 else 0] -- ltWord8# :: Word8# -> Word8# -> Int# - ( "ltWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a < b then 1 else 0] + ( "ltWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a < b then 1 else 0] -- neWord8# :: Word8# -> Word8# -> Int# - ( "neWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a /= b then 1 else 0] + ( "neWord8#", [Word8V a, Word8V b]) -> pure [IntV $ if a /= b then 1 else 0] -- OBSOLETE from GHC 9.2 -- extendWord8# :: Word8# -> Word# - ( "extendWord8#", [Word8V a]) -> pure [WordV a] + ( "extendWord8#", [Word8V a]) -> pure [WordV a] -- OBSOLETE from GHC 9.2 -- narrowWord8# :: Word# -> Word8# - ( "narrowWord8#", [WordV a]) -> pure [Word8V . w . w8 $ a] + ( "narrowWord8#", [WordV a]) -> pure [Word8V . w . w8 $ a] - _ -> fallback op args t tc + _ -> fallback op args t tc diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Rts.hs b/external-stg-interpreter/lib/Stg/Interpreter/Rts.hs index a12edf4..f887a80 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/Rts.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/Rts.hs @@ -1,29 +1,75 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.Rts (initRtsSupport, extStgRtsSupportModule, globalStoreSymbols) where -import GHC.Stack -import Control.Monad.State -import Control.Concurrent.MVar +import Control.Monad (Functor (..), forM_) +import Control.Monad.State (MonadIO (..), gets, modify') + +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Int (Int) +import Data.List (concatMap, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import Data.Monoid (Monoid (..)) +import qualified Data.Set as Set +import Data.String (String) +import Data.Tuple (fst) + +import Foreign.Marshal.Utils (new) -import Foreign.Marshal.Utils +import GHC.Err (error, undefined) -import Data.List (foldl') -import qualified Data.Set as Set -import qualified Data.Map as Map +import Stg.Interpreter.Base (Atom, M, Rts (..), StgState (..), lookupEnv, promptM_) +import Stg.Reconstruct (reconModule) +import Stg.Syntax (Alt' (..), AltCon' (..), AltType' (..), Arg' (..), Binder (..), BinderId (..), + Binding' (..), DataCon (..), DataConId (..), DataConRep (..), Expr' (..), + ForeignStubs' (..), IdDetails (..), Module, Module' (..), ModuleName (..), Name, + PrimRep (..), Rhs' (..), SBinder (..), SDataCon (..), STyCon (..), Scope (..), + SrcSpan (..), TopBinding' (..), TyCon (..), TyConId (..), Type (..), + UnhelpfulSpanReason (..), Unique (..), UnitId (..), UpdateFlag (..)) -import Stg.Syntax -import Stg.Reconstruct -import Stg.Interpreter.Base +import System.IO (print, putStrLn) -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) +import Text.Show (Show (..)) +emptyRts :: String -> [String] -> Rts emptyRts progName progArgs = Rts - { rtsGlobalStore = Map.empty - , rtsProgName = progName - , rtsProgArgs = progArgs + { rtsGlobalStore = Map.empty + , rtsProgName = progName + , rtsProgArgs = progArgs + , rtsCharCon = undefined + , rtsIntCon = undefined + , rtsInt8Con = undefined + , rtsInt16Con = undefined + , rtsInt32Con = undefined + , rtsInt64Con = undefined + , rtsWordCon = undefined + , rtsWord8Con = undefined + , rtsWord16Con = undefined + , rtsWord32Con = undefined + , rtsWord64Con = undefined + , rtsPtrCon = undefined + , rtsFunPtrCon = undefined + , rtsFloatCon = undefined + , rtsDoubleCon = undefined + , rtsStablePtrCon = undefined + , rtsTrueCon = undefined + , rtsFalseCon = undefined + -- , rtsUnpackCString = undefined + , rtsTopHandlerRunIO = undefined + , rtsTopHandlerRunNonIO = undefined + , rtsTopHandlerFlushStdHandles = undefined + , rtsDivZeroException = undefined + , rtsUnderflowException = undefined + , rtsOverflowException = undefined + , rtsNestedAtomically = undefined + , rtsBlockedIndefinitelyOnMVar = undefined + , rtsBlockedIndefinitelyOnSTM = undefined + , rtsNonTermination = undefined + , rtsApplyFun1Arg = undefined + , rtsTuple2Proj0 = undefined + , rtsDataSymbol_enabled_capabilities = undefined } initRtsCDataSymbols :: M () @@ -39,7 +85,7 @@ initRtsSupport :: String -> [String] -> [Module] -> M () initRtsSupport progName progArgs mods = do -- create empty Rts data con, it is filled gradually - modify' $ \s@StgState{..} -> s {ssRtsSupport = emptyRts progName progArgs} + modify' $ \s -> s {ssRtsSupport = emptyRts progName progArgs} initRtsCDataSymbols -- collect rts related modules @@ -51,7 +97,7 @@ initRtsSupport progName progArgs mods = do -- lookup wired-in constructors let dcMap = Map.fromList [ ((moduleUnitId, moduleName, tcName, dcName), dc) - | m@Module{..} <- rtsMods + | Module{..} <- rtsMods , (tcU, tcMs) <- moduleTyCons , tcU == moduleUnitId , (tcM, tcs) <- tcMs @@ -68,11 +114,11 @@ initRtsSupport progName progArgs mods = do -- lookup wired-in closures let getBindings = \case StgTopLifted (StgNonRec i _) -> [i] - StgTopLifted (StgRec l) -> map fst l + StgTopLifted (StgRec l) -> fmap fst l _ -> [] closureMap = Map.fromList [ ((uId, mName, bName), topBinding) - | m@Module{..} <- rtsMods + | Module{..} <- rtsMods , topBinding@Binder{..} <- concatMap getBindings moduleTopBindings , (uId, mName, bName, _) <- wiredInClosures , UnitId uId == moduleUnitId @@ -81,12 +127,12 @@ initRtsSupport progName progArgs mods = do ] promptM_ $ do - forM_ mods $ \m@Module{..} -> do + forM_ mods $ \Module{..} -> do liftIO $ print (moduleUnitId, moduleName) forM_ wiredInClosures $ \(u, m, n, setter) -> do case Map.lookup (u, m, n) closureMap of - Nothing -> liftIO $ putStrLn $ "missing wired in closure: " ++ show (u, m, n)-- ++ "\n" ++ unlines (map show $ Map.keys closureMap) + Nothing -> liftIO $ putStrLn $ "missing wired in closure: " ++ show (u, m, n)-- ++ "\n" ++ unlines (fmap show $ Map.keys closureMap) Just b -> do cl <- lookupEnv mempty b modify' $ \s@StgState{..} -> s {ssRtsSupport = setter ssRtsSupport cl} @@ -149,7 +195,6 @@ wiredInClosures = [ ("ghc-internal", "GHC.Internal.TopHandler", "runIO", \s cl -> s {rtsTopHandlerRunIO = cl}) , ("ghc-internal", "GHC.Internal.TopHandler", "runNonIO", \s cl -> s {rtsTopHandlerRunNonIO = cl}) , ("ghc-internal", "GHC.Internal.TopHandler", "flushStdHandles", \s cl -> s {rtsTopHandlerFlushStdHandles = cl}) - , ("ghc-internal", "GHC.Internal.Pack", "unpackCString", \s cl -> s {rtsUnpackCString = cl}) , ("ghc-internal", "GHC.Internal.Exception.Type", "divZeroException", \s cl -> s {rtsDivZeroException = cl}) , ("ghc-internal", "GHC.Internal.Exception.Type", "underflowException", \s cl -> s {rtsUnderflowException = cl}) , ("ghc-internal", "GHC.Internal.Exception.Type", "overflowException", \s cl -> s {rtsOverflowException = cl}) diff --git a/external-stg-interpreter/lib/Stg/Interpreter/RtsFFI.hs b/external-stg-interpreter/lib/Stg/Interpreter/RtsFFI.hs index edb89ac..f7a3f9f 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/RtsFFI.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/RtsFFI.hs @@ -1,65 +1,59 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.RtsFFI where ----- FFI experimental -import qualified GHC.Exts as Exts -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS - -import Foreign.Storable -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import Data.Word -import Data.Int -import Data.Maybe -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import qualified Data.Primitive.ByteArray as BA ------ -import System.Exit -import System.IO -import System.FilePath -import Text.Printf - -import Data.Time.Clock - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -import GHC.Stack -import Control.Monad.State.Strict -import Control.Concurrent.MVar - -import Stg.Syntax -import Stg.GHC.Symbols -import Stg.Interpreter.Base -import Stg.Interpreter.Debug -import Stg.Interpreter.Rts (globalStoreSymbols) - -pattern CharV c = Literal (LitChar c) -pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) -pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) -pattern FloatV f = FloatAtom f -pattern DoubleV d = DoubleAtom d +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Monad (..), mapM) +import Control.Monad.State.Strict (MonadIO (..), MonadState (..), gets, modify') + +import Data.Bool (Bool (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Int (Int) +import Data.List (filter, length, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..)) +import Data.Ord (Ord (..)) +import qualified Data.Primitive.ByteArray as BA +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) +import Data.Word (Word, Word64) + +import Foreign (Int64, fromBool) +import Foreign.C.String (CString, newCString, peekCString) +import Foreign.C.Types (CBool (..), CInt (..)) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Marshal.Array (newArray, peekArray) +import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) +import Foreign.Storable (Storable (..)) + +import qualified GHC.Exts as Exts +import GHC.Float (Double, Float) +import GHC.Num (Num (..)) +import GHC.Real (Integral (..), fromIntegral) +import GHC.Stack (HasCallStack) + +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Interpreter.Debug (exportCallGraph) +import Stg.Interpreter.Rts (globalStoreSymbols) +import Stg.Syntax (CCallTarget (..), ForeignCall (..), PrimRep (..), TyCon, Type (..)) + +import System.Exit (ExitCode (..), exitWith) +import System.FilePath (takeBaseName) +import System.IO (IO, hFlush, hPutStr, hPutStrLn, print, putStrLn, stderr) + +import Text.Printf (printf) +import Text.Show (Show (..)) {-# NOINLINE evalFCallOp #-} -evalFCallOp :: EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] -evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do +evalFCallOp :: HasCallStack => EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] +evalFCallOp _evalOnNewThread fCall@ForeignCall{..} args t _tc = do --liftIO $ putStrLn $ "[evalFCallOp] " ++ show foreignCTarget ++ " " ++ show args case foreignCTarget of @@ -108,11 +102,11 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do StaticTarget _ "freeHaskellFunctionPtr" _ _ -> pure [] -- TODO StaticTarget _ "performMajorGC" _ _ -> do - modify' $ \s@StgState{..} -> s {ssRequestMajorGC = True} + modify' $ \s -> s {ssRequestMajorGC = True} pure [] StaticTarget _ "setNumCapabilities" _ _ - | [WordV num_caps, Void] <- args + | [WordV _num_caps, Void] <- args -> do pure [] -- TODO @@ -132,7 +126,7 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do StaticTarget _ "rts_setMainThread" _ _ | [WeakPointer weakId, Void] <- args -> do - wd <- lookupWeakPointerDescriptor weakId + _wd <- lookupWeakPointerDescriptor weakId --error $ show wd pure [] -- TODO @@ -158,17 +152,17 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do StaticTarget _ "stg_sig_install" _ _ -> pure [IntV (-1)] -- TODO: for testsuite StaticTarget _ "lockFile" _ _ - | [Word64V id, Word64V dev, Word64V ino, Int32V for_writing, Void] <- args + | [Word64V id', Word64V dev, Word64V ino, Int32V for_writing, Void] <- args , UnboxedTuple [Int32Rep] <- t -> do - result <- liftIO $ lockFile (fromIntegral id) (fromIntegral dev) (fromIntegral ino) (fromIntegral for_writing) + result <- liftIO $ lockFile (fromIntegral id') (fromIntegral dev) (fromIntegral ino) (fromIntegral for_writing) pure [Int32V $ fromIntegral result] StaticTarget _ "unlockFile" _ _ - | [Word64V id, Void] <- args + | [Word64V id', Void] <- args , UnboxedTuple [Int32Rep] <- t -> do - result <- liftIO $ unlockFile (fromIntegral id) + result <- liftIO $ unlockFile (fromIntegral id') pure [Int32V $ fromIntegral result] StaticTarget _ "rtsSupportsBoundThreads" _ _ -> pure [IntV 0] @@ -183,14 +177,14 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do | [IntAtom argc, PtrAtom _ argvPtr, Void] <- args -> do liftIO $ do - -- peekCString :: CString -> IO String + -- peekCString :: CString -> IO String argv <- peekArray argc (castPtr argvPtr) >>= mapM peekCString print (argc, argv) -- TODO: save to the env!! pure [] StaticTarget _ "getProgArgv" _ _ - | [PtrAtom (ByteArrayPtr ba1) ptrArgc, PtrAtom (ByteArrayPtr ba2) ptrArgv, Void] <- args + | [PtrAtom (ByteArrayPtr _ba1) ptrArgc, PtrAtom (ByteArrayPtr _ba2) ptrArgv, Void] <- args -> do Rts{..} <- gets ssRtsSupport liftIO $ do @@ -199,14 +193,14 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do -- FIXME: this has a race condition with the GC!!!! because it is pure arr1 <- newCString rtsProgName :: IO CString - args <- mapM newCString rtsProgArgs :: IO [CString] - arr2 <- newArray (arr1 : args ++ [nullPtr]) :: IO (Ptr CString) + args' <- mapM newCString rtsProgArgs :: IO [CString] + arr2 <- newArray (arr1 : args' ++ [nullPtr]) :: IO (Ptr CString) poke (castPtr ptrArgv :: Ptr (Ptr CString)) arr2--(castPtr arr2 :: Ptr CString ) pure [] StaticTarget _ "shutdownHaskellAndExit" _ _ - | [IntV retCode, IntV fastExit, Void] <- args + | [IntV retCode, IntV _sfastExit, Void] <- args , UnboxedTuple [] <- t -> do --showDebug evalOnNewThread @@ -257,12 +251,34 @@ evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do , [value, Void] <- args -> do -- HINT: set once with the first value, then return it always, only for the globalStoreSymbols - store <- gets $ rtsGlobalStore . ssRtsSupport - case Map.lookup foreignSymbol store of - Nothing -> state $ \s@StgState{..} -> ([value], s {ssRtsSupport = ssRtsSupport {rtsGlobalStore = Map.insert foreignSymbol value store}}) + store' <- gets $ rtsGlobalStore . ssRtsSupport + case Map.lookup foreignSymbol store' of + Nothing -> state $ \s@StgState{..} -> ([value], s {ssRtsSupport = ssRtsSupport {rtsGlobalStore = Map.insert foreignSymbol value store'}}) Just v -> pure [v] - _ -> stgErrorM $ "unsupported RTS StgFCallOp: " ++ show fCall ++ " :: " ++ show t ++ "\n args: " ++ show args + -- Assume charset names are ASCII + StaticTarget _ "localeEncoding" _ _ + | [Void] <- args + , UnboxedTuple [AddrRep] <- t + -> do + let bsCString = "UTF-8" + (bsFPtr, bsOffset, _bsLen) = BS.toForeignPtr bsCString + pure [PtrAtom (CStringPtr bsCString) $ plusPtr (unsafeForeignPtrToPtr bsFPtr) bsOffset] + + -- 1 => Input ready, 0 => not ready, -1 => error + StaticTarget _ "fdReady" _ _ + | [IntAtom i, WordAtom b, IntAtom ii, WordAtom bb, Void] <- args + -> do + let i' = toEnum i + b' = Foreign.fromBool $ if b == 0 then True else False + ii' = toEnum ii + bb' = Foreign.fromBool $ if bb == 0 then True else False + fd <- liftIO $ fdReady i' b' ii' bb' + pure [IntAtom $ fromEnum fd] + + StaticTarget _ _ _ _ -> stgErrorM $ "unsupported RTS StgFCallOp: " ++ show fCall ++ " :: " ++ show t ++ "\n args: " ++ show args + + DynamicTarget -> stgErrorM "unsupported DynamicTarget" foreign import ccall unsafe "__int_encodeDouble" rts_intEncodeDouble :: Int -> Int -> Double @@ -272,3 +288,4 @@ foreign import ccall unsafe "__word_encodeFloat" rts_wordEncodeFloat :: Word - foreign import ccall unsafe "lockFile" lockFile :: Word64 -> Word64 -> Word64 -> CInt -> IO CInt foreign import ccall unsafe "unlockFile" unlockFile :: Word64 -> IO CInt +foreign import ccall safe "fdReady" fdReady :: CInt -> CBool -> Foreign.Int64 -> CBool -> IO CInt diff --git a/external-stg-interpreter/lib/Stg/Interpreter/ThreadScheduler.hs b/external-stg-interpreter/lib/Stg/Interpreter/ThreadScheduler.hs index 9606628..14e42d2 100644 --- a/external-stg-interpreter/lib/Stg/Interpreter/ThreadScheduler.hs +++ b/external-stg-interpreter/lib/Stg/Interpreter/ThreadScheduler.hs @@ -1,26 +1,43 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} + module Stg.Interpreter.ThreadScheduler where -import Control.Monad.State -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Time.Clock -import System.IO +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..), forM_, when) +import Control.Monad.State (MonadIO (..), gets, modify') +import qualified Control.Monad.Trans.State.Strict as Strict + +import Data.Bool (Bool (..), not, (&&)) +import Data.Eq (Eq (..)) +import Data.Function (flip, id, ($), (.)) +import Data.Int (Int) +import qualified Data.IntMap as IntMap +import Data.List (drop, elem, null, sortOn, (++)) +import Data.Maybe (maybe) +import Data.Ord (Ord (..)) +import Data.Time.Clock (getCurrentTime) + +import GHC.Err (error, undefined) + +import Stg.Interpreter.Base (Atom, BlockReason (..), Breakpoint (..), DebugState (..), M, + ScheduleReason (..), StgState (..), ThreadState (..), + ThreadStatus (..), dumpStgState, getThreadState, lookupMVar, mylog, + promptM, promptM_, reportThreads, switchToThread, traceLog, + updateThreadState) +import qualified Stg.Interpreter.Debugger as Debugger +import qualified Stg.Interpreter.GC as GC +import Stg.Interpreter.IOManager (handleBlockedDelayWait) +import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency + +import System.IO (IO, print, putStrLn) + +import Text.Show (Show (..)) -import Text.Pretty.Simple (pShowNoColor) -import qualified Data.Text.Lazy.IO as Text -import Data.List -import Stg.Interpreter.Base -import Stg.Interpreter.IOManager -import qualified Stg.Interpreter.Debugger as Debugger -import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency -import qualified Stg.Interpreter.GC as GC runScheduler :: [Atom] -> ScheduleReason -> M [Atom] runScheduler result sr = do --debugAsyncExceptions tid <- gets ssCurrentThreadId - threads <- gets ssThreads + _threads <- gets ssThreads promptM $ do putStrLn $ " * scheduler: " ++ show sr ++ " thread: " ++ show tid ++ " result: " ++ show result --Text.putStrLn $ pShowNoColor threads @@ -50,6 +67,7 @@ runScheduler result sr = do SR_ThreadYield -> yield result +yield :: [Atom] -> Strict.StateT StgState IO [Atom] yield result = do tid <- gets ssCurrentThreadId ts <- getThreadState tid @@ -82,7 +100,7 @@ yield result = do now <- liftIO $ getCurrentTime --putStrLn $ show now ++ " * scheduler next runnable thread: " ++ show nextTid ++ " " ++ show [(i, tsStatus t) | (i, t) <- IntMap.toList threads, tsStatus t == ThreadRunning] liftIO $ putStrLn $ show now ++ " * scheduler next runnable thread: " ++ show nextTid ++ " " ++ show [(i, tsStatus t, tsLabel t) | (i, t) <- IntMap.toList threads] - forM_ [(i, tsStatus t) | (i, t) <- IntMap.toList threads] $ \(i, status) -> case status of + forM_ [(i, tsStatus t) | (i, t) <- IntMap.toList threads] $ \(_i, status') -> case status' of ThreadBlocked (BlockedOnMVar mid _) -> do md <- lookupMVar mid liftIO $ putStrLn $ "mvarId: " ++ show mid ++ " " ++ show md @@ -94,13 +112,13 @@ yield result = do -- validate ex mask state - when (tsInterruptible nextTS && tsBlockExceptions nextTS == False) $ do + when (tsInterruptible nextTS && not (tsBlockExceptions nextTS)) $ do reportThreads error $ "invalid ex mask: " ++ show (nextTid, tsBlockExceptions nextTS, tsInterruptible nextTS) -- TODO: rethink, validate, reimplement this correctly, check how it is done in native -- try to raise async exceptions from the queue if possible - if (tsBlockExceptions nextTS == False) -- || (tsInterruptible nextTS && interruptible (tsStatus nextTS))) + if (not (tsBlockExceptions nextTS)) -- || (tsInterruptible nextTS && interruptible (tsStatus nextTS))) then case tsBlockedExceptions nextTS of [] -> pure $ tsCurrentResult nextTS (thowingTid, exception) : waitingTids -> do @@ -181,16 +199,18 @@ data ThreadStatus , tsInterruptible :: !Bool -- interruptible blocking of async exception -} tryRaiseBlockedException :: [Atom] -> M [Atom] -tryRaiseBlockedException result = do +tryRaiseBlockedException _result = do pure [] getNextRunnableThread :: M Int getNextRunnableThread = do -- HINT: drop current thread id tidQueue <- gets $ drop 1 . ssScheduledThreadIds - modify' $ \s@StgState{..} -> s {ssScheduledThreadIds = tidQueue} + modify' $ \s -> s {ssScheduledThreadIds = tidQueue} case tidQueue of - [] -> head <$> calculateNewSchedule + [] -> (flip fmap) calculateNewSchedule $ \case + [] -> undefined + (a : _) -> a tid : _ -> do ts <- getThreadState tid if tsStatus ts == ThreadRunning @@ -279,12 +299,12 @@ stopIfThereIsNoRunnableThread = do --reportThreads tsList <- gets $ IntMap.toList . ssThreads liftIO $ do - putStrLn $ "[stopIfThereIsNoRunnableThread] No runnable threads, STOP!" - putStrLn $ "[stopIfThereIsNoRunnableThread] - all thread status list: " + putStrLn "[stopIfThereIsNoRunnableThread] No runnable threads, STOP!" + putStrLn "[stopIfThereIsNoRunnableThread] - all thread status list: " forM_ tsList $ \(tid, ts) -> do - putStrLn $ show (tid, tsStatus ts, tsBlockExceptions ts, tsInterruptible ts, tsBlockedExceptions ts, tsLabel ts) + print (tid, tsStatus ts, tsBlockExceptions ts, tsInterruptible ts, tsBlockedExceptions ts, tsLabel ts) dumpStgState - modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep} + modify' $ \s -> s {ssDebugState = DbgStepByStep} Debugger.checkBreakpoint [] $ BkpCustom "thread-scheduler" {- diff --git a/external-stg-interpreter/souffle b/external-stg-interpreter/souffle new file mode 160000 index 0000000..94ccab0 --- /dev/null +++ b/external-stg-interpreter/souffle @@ -0,0 +1 @@ +Subproject commit 94ccab0127d78a2c295730e8c8f560aabc82ea0f diff --git a/external-stg-interpreter/test/PrimOp/AddrSpec.hs b/external-stg-interpreter/test/PrimOp/AddrSpec.hs index e848938..63d7ca6 100644 --- a/external-stg-interpreter/test/PrimOp/AddrSpec.hs +++ b/external-stg-interpreter/test/PrimOp/AddrSpec.hs @@ -1,21 +1,30 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} module PrimOp.AddrSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Function (($)) +import Data.Maybe (Maybe (..)) +import Data.Word (Word8) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Addr +import Foreign.Ptr (WordPtr (..), wordPtrToPtr) -import Foreign.Ptr -import Data.Word -import GHC.Exts +import GHC.Exts + +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Addr +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Expectation, HasCallStack, Spec, describe, hspec, it, shouldReturn) +import Test.QuickCheck (NonZero (..), Testable (..)) + +import Text.Show (Show (..)) runTests :: IO () runTests = hspec spec @@ -34,7 +43,7 @@ unboxPtr (Ptr x) = x unboxInt :: Int -> Int# unboxInt (I# x) = x -shouldReturnShow :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +shouldReturnShow :: (HasCallStack, Show a) => IO a -> a -> Expectation shouldReturnShow m a = fmap show m `shouldReturn` show a spec :: Spec diff --git a/external-stg-interpreter/test/PrimOp/CharSpec.hs b/external-stg-interpreter/test/PrimOp/CharSpec.hs index a6dd82f..1503d0c 100644 --- a/external-stg-interpreter/test/PrimOp/CharSpec.hs +++ b/external-stg-interpreter/test/PrimOp/CharSpec.hs @@ -1,19 +1,26 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, Strict #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} module PrimOp.CharSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Char +import GHC.Exts -import GHC.Exts +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Char +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec diff --git a/external-stg-interpreter/test/PrimOp/DoubleSpec.hs b/external-stg-interpreter/test/PrimOp/DoubleSpec.hs index 9f7ee82..168692d 100644 --- a/external-stg-interpreter/test/PrimOp/DoubleSpec.hs +++ b/external-stg-interpreter/test/PrimOp/DoubleSpec.hs @@ -1,19 +1,28 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.DoubleSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Double +import GHC.Exts -import GHC.Exts +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Double +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Expectation, HasCallStack, Spec, describe, hspec, it, shouldReturn) +import Test.QuickCheck (NonZero (..), Testable (..)) + +import Text.Show (Show (..)) runTests :: IO () runTests = hspec spec @@ -29,7 +38,7 @@ evalOp op args = do unboxDouble :: Double -> Double# unboxDouble (D# x) = x -shouldReturnShow :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +shouldReturnShow :: (HasCallStack, Show a) => IO a -> a -> Expectation shouldReturnShow m a = fmap show m `shouldReturn` show a spec :: Spec @@ -101,7 +110,6 @@ spec = do property $ \(a :: Double) -> do evalOp "logDouble#" [DoubleV a] `shouldReturnShow` [DoubleV (D# (logDouble# (unboxDouble a)))] -#if __GLASGOW_HASKELL__ >= 810 it "expm1Double#" $ property $ \(a :: Double) -> do evalOp "expm1Double#" [DoubleV a] `shouldReturn` [DoubleV (D# (expm1Double# (unboxDouble a)))] @@ -109,7 +117,6 @@ spec = do it "log1pDouble#" $ property $ \(a :: Double) -> do evalOp "log1pDouble#" [DoubleV a] `shouldReturnShow` [DoubleV (D# (log1pDouble# (unboxDouble a)))] -#endif it "sqrtDouble#" $ property $ \(a :: Double) -> do @@ -176,4 +183,5 @@ spec = do it "decodeDouble_Int64#" $ property $ \(a :: Double) -> do let !(# x, y #) = decodeDouble_Int64# (unboxDouble a) - evalOp "decodeDouble_Int64#" [DoubleV a] `shouldReturn` [IntV (I# x), IntV (I# y)] + let x' = int64ToInt# x + evalOp "decodeDouble_Int64#" [DoubleV a] `shouldReturn` [IntV (I# x'), IntV (I# y)] diff --git a/external-stg-interpreter/test/PrimOp/FloatSpec.hs b/external-stg-interpreter/test/PrimOp/FloatSpec.hs index ca7883c..dbd6fed 100644 --- a/external-stg-interpreter/test/PrimOp/FloatSpec.hs +++ b/external-stg-interpreter/test/PrimOp/FloatSpec.hs @@ -1,19 +1,31 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.FloatSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Float +import GHC.Exts -import GHC.Exts +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Float +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Expectation, HasCallStack, Spec, describe, hspec, it, shouldReturn) +import Test.QuickCheck (Arbitrary (..), Gen, NonNegative (..), NonZero (..), Positive (..), + Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) + +import Text.Show (Show (..)) runTests :: IO () runTests = hspec spec @@ -37,7 +49,7 @@ evalOp2 op args = do unboxFloat :: Float -> Float# unboxFloat (F# x) = x -shouldReturnShow :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +shouldReturnShow :: (HasCallStack, Show a) => IO a -> a -> Expectation shouldReturnShow m a = fmap show m `shouldReturn` show a spec :: Spec @@ -120,7 +132,6 @@ spec = do [FloatV stgVal] <- evalOp "logFloat#" [FloatV a] assert $ stgVal == (F# (logFloat# (unboxFloat a))) -#if __GLASGOW_HASKELL__ >= 810 it "expm1Float#" $ property $ forAll (arbitrary :: Gen Float) $ \a -> monadicIO $ do [FloatV stgVal] <- evalOp "expm1Float#" [FloatV a] @@ -130,7 +141,6 @@ spec = do property $ forAll (arbitrary :: Gen (Positive Float)) $ \(Positive a) -> monadicIO $ do [FloatV stgVal] <- evalOp "log1pFloat#" [FloatV a] assert $ stgVal == (F# (log1pFloat# (unboxFloat a))) -#endif it "logFloat#" $ property $ forAll (arbitrary :: Gen (Positive Float)) $ \(Positive a) -> monadicIO $ do diff --git a/external-stg-interpreter/test/PrimOp/Int16Spec.hs b/external-stg-interpreter/test/PrimOp/Int16Spec.hs index c085f81..b0fd91b 100644 --- a/external-stg-interpreter/test/PrimOp/Int16Spec.hs +++ b/external-stg-interpreter/test/PrimOp/Int16Spec.hs @@ -1,20 +1,28 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.Int16Spec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Int16 +import GHC.Exts +import GHC.Int (Int16 (..)) +import GHC.Real (fromIntegral) -import GHC.Exts -import GHC.Int +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Int16 +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, NonZero (..), Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec diff --git a/external-stg-interpreter/test/PrimOp/Int8Spec.hs b/external-stg-interpreter/test/PrimOp/Int8Spec.hs index 05199f3..fb0345e 100644 --- a/external-stg-interpreter/test/PrimOp/Int8Spec.hs +++ b/external-stg-interpreter/test/PrimOp/Int8Spec.hs @@ -1,20 +1,28 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.Int8Spec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (Nothing)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Int8 +import GHC.Exts +import GHC.Int (Int8 (..)) +import GHC.Real (fromIntegral) -import GHC.Exts -import GHC.Int +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Int8 +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, NonZero (..), Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec diff --git a/external-stg-interpreter/test/PrimOp/IntSpec.hs b/external-stg-interpreter/test/PrimOp/IntSpec.hs index 174e838..f9fe166 100644 --- a/external-stg-interpreter/test/PrimOp/IntSpec.hs +++ b/external-stg-interpreter/test/PrimOp/IntSpec.hs @@ -1,20 +1,28 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.IntSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Char (ord) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Int +import GHC.Exts -import GHC.Exts -import Data.Char +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Int +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, NonZero (..), Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec @@ -53,14 +61,12 @@ spec = do [IntV stgVal] <- evalOp "*#" [IntV a, IntV b] assert $ stgVal == (I# ((unboxInt a) *# (unboxInt b))) -#if __GLASGOW_HASKELL__ >= 900 it "timesInt2#" $ property $ forAll (arbitrary :: Gen (Int, Int)) $ \(a, b) -> monadicIO $ do [IntV stgVal1, IntV stgVal2, IntV stgVal3] <- evalOp "timesInt2#" [IntV a, IntV b] let !(# x, y, z #) = timesInt2# (unboxInt a) (unboxInt b) assert $ (stgVal1, stgVal2, stgVal3) == (I# x, I# y, I# z) -#endif it "mulIntMayOflo#" $ property $ forAll (arbitrary :: Gen (Int, Int)) $ \(a, b) -> monadicIO $ do diff --git a/external-stg-interpreter/test/PrimOp/NarrowingsSpec.hs b/external-stg-interpreter/test/PrimOp/NarrowingsSpec.hs index b70141c..13a7dc1 100644 --- a/external-stg-interpreter/test/PrimOp/NarrowingsSpec.hs +++ b/external-stg-interpreter/test/PrimOp/NarrowingsSpec.hs @@ -1,19 +1,25 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} module PrimOp.NarrowingsSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Narrowings +import GHC.Exts -import GHC.Exts +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Narrowings +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec diff --git a/external-stg-interpreter/test/PrimOp/Word16Spec.hs b/external-stg-interpreter/test/PrimOp/Word16Spec.hs index 043db9f..ed7bc98 100644 --- a/external-stg-interpreter/test/PrimOp/Word16Spec.hs +++ b/external-stg-interpreter/test/PrimOp/Word16Spec.hs @@ -1,20 +1,28 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.Word16Spec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Word16 +import GHC.Exts +import GHC.Real (fromIntegral) +import GHC.Word (Word16 (..)) -import GHC.Exts -import GHC.Word +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Word16 +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, NonZero (..), Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec diff --git a/external-stg-interpreter/test/PrimOp/Word8Spec.hs b/external-stg-interpreter/test/PrimOp/Word8Spec.hs index 4e850f6..9b02685 100644 --- a/external-stg-interpreter/test/PrimOp/Word8Spec.hs +++ b/external-stg-interpreter/test/PrimOp/Word8Spec.hs @@ -1,20 +1,28 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.Word8Spec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Word8 +import GHC.Exts +import GHC.Real (fromIntegral) +import GHC.Word (Word8 (..)) -import GHC.Exts -import GHC.Word +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Word8 +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Spec, describe, hspec, it) +import Test.QuickCheck (Arbitrary (..), Gen, NonZero (..), Testable (..), forAll) +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run) runTests :: IO () runTests = hspec spec diff --git a/external-stg-interpreter/test/PrimOp/WordSpec.hs b/external-stg-interpreter/test/PrimOp/WordSpec.hs index f9839f2..ae059b3 100644 --- a/external-stg-interpreter/test/PrimOp/WordSpec.hs +++ b/external-stg-interpreter/test/PrimOp/WordSpec.hs @@ -1,20 +1,33 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} module PrimOp.WordSpec where -import Control.Monad.State.Strict +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..)) +import Control.Monad.State.Strict (evalStateT) -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Monadic +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) +import Data.Ord (Ord (..)) -import Stg.Syntax (Name, Type(..)) -import Stg.Interpreter.Base -import Stg.Interpreter.PrimOp.Word +import GHC.Exts -import GHC.Word -import GHC.Exts +import Prelude (Enum (..)) + +import Stg.Interpreter.Base +import Stg.Interpreter.PrimOp.Word +import Stg.Syntax (Name, Type (..)) + +import System.IO (IO) + +import Test.Hspec (Expectation, HasCallStack, Spec, describe, hspec, it, shouldReturn) +import Test.QuickCheck (NonZero (..), Testable (..)) +import Test.QuickCheck.Monadic (assert, monadicIO, run) + +import Text.Show (Show (..)) runTests :: IO () runTests = hspec spec @@ -33,7 +46,7 @@ unboxWord (W# x) = x unboxInt :: Int -> Int# unboxInt (I# x) = x -shouldReturnShow :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +shouldReturnShow :: (HasCallStack, Show a) => IO a -> a -> Expectation shouldReturnShow m a = fmap show m `shouldReturn` show a spec :: Spec @@ -171,7 +184,7 @@ spec = do it "popCnt64#" $ property $ \(a :: Word) -> do - evalOp "popCnt64#" [WordV a] `shouldReturn` [WordV (W# (popCnt64# (unboxWord a)))] + evalOp "popCnt64#" [WordV a] `shouldReturn` [WordV (W# (popCnt64# (wordToWord64# (unboxWord a))))] it "popCnt#" $ property $ \(a :: Word) -> do @@ -191,7 +204,9 @@ spec = do it "pdep64#" $ property $ \(a :: Word, b :: Word) -> do - evalOp "pdep64#" [WordV a, WordV b] `shouldReturn` [WordV (W# (pdep64# (unboxWord a) (unboxWord b)))] + let a' = wordToWord64# (unboxWord a) + let b' = wordToWord64# (unboxWord b) + evalOp "pdep64#" [WordV a, WordV b] `shouldReturn` [WordV (W# (word64ToWord# (pdep64# a' b')))] it "pdep#" $ property $ \(a :: Word, b :: Word) -> do @@ -211,7 +226,9 @@ spec = do it "pext64#" $ property $ \(a :: Word, b :: Word) -> do - evalOp "pext64#" [WordV a, WordV b] `shouldReturn` [WordV (W# (pext64# (unboxWord a) (unboxWord b)))] + let a' = wordToWord64# (unboxWord a) + let b' = wordToWord64# (unboxWord b) + evalOp "pext64#" [WordV a, WordV b] `shouldReturn` [WordV (W# (word64ToWord# (pext64# a' b')))] it "pext#" $ property $ \(a :: Word, b :: Word) -> do @@ -231,7 +248,8 @@ spec = do it "clz64#" $ property $ \(a :: Word) -> do - evalOp "clz64#" [WordV a] `shouldReturn` [WordV (W# (clz64# (unboxWord a)))] + let a' = wordToWord64# (unboxWord a) + evalOp "clz64#" [WordV a] `shouldReturn` [WordV (W# (clz64# a'))] it "clz#" $ property $ \(a :: Word) -> do @@ -251,7 +269,8 @@ spec = do it "ctz64#" $ property $ \(a :: Word) -> do - evalOp "ctz64#" [WordV a] `shouldReturn` [WordV (W# (ctz64# (unboxWord a)))] + let a' = wordToWord64# (unboxWord a) + evalOp "ctz64#" [WordV a] `shouldReturn` [WordV (W# (ctz64# a'))] it "ctz#" $ property $ \(a :: Word) -> do @@ -267,13 +286,13 @@ spec = do it "byteSwap64#" $ property $ \(a :: Word) -> do - evalOp "byteSwap64#" [WordV a] `shouldReturn` [WordV (W# (byteSwap64# (unboxWord a)))] + let a' = wordToWord64# (unboxWord a) + evalOp "byteSwap64#" [WordV a] `shouldReturn` [WordV (W# (word64ToWord# (byteSwap64# a')))] it "byteSwap#" $ property $ \(a :: Word) -> do evalOp "byteSwap#" [WordV a] `shouldReturn` [WordV (W# (byteSwap# (unboxWord a)))] -#if __GLASGOW_HASKELL__ >= 810 it "bitReverse8#" $ property $ \(a :: Word) -> do evalOp "bitReverse8#" [WordV a] `shouldReturn` [WordV (W# (bitReverse8# (unboxWord a)))] @@ -288,9 +307,9 @@ spec = do it "bitReverse64#" $ property $ \(a :: Word) -> do - evalOp "bitReverse64#" [WordV a] `shouldReturn` [WordV (W# (bitReverse64# (unboxWord a)))] + let a' = wordToWord64#(unboxWord a) + evalOp "bitReverse64#" [WordV a] `shouldReturn` [WordV (W# (word64ToWord# (bitReverse64# a')))] it "bitReverse#" $ property $ \(a :: Word) -> do evalOp "bitReverse#" [WordV a] `shouldReturn` [WordV (W# (bitReverse# (unboxWord a)))] -#endif diff --git a/external-stg-syntax/Setup.hs b/external-stg-syntax/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/external-stg-syntax/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/external-stg-syntax/external-stg-syntax.cabal b/external-stg-syntax/external-stg-syntax.cabal index e0e80b2..ea85820 100644 --- a/external-stg-syntax/external-stg-syntax.cabal +++ b/external-stg-syntax/external-stg-syntax.cabal @@ -1,22 +1,35 @@ +cabal-version: 3.14 name: external-stg-syntax version: 1.0.2 synopsis: GHC independent STG IR definition -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Csaba Hruska maintainer: csaba.hruska@gmail.com copyright: (c) 2022 Csaba Hruska category: Development build-type: Simple -tested-with: GHC==9.2.4 -cabal-version: >=1.10 library + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards + ghc-options: + -Wall + -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Widentities + -Wunused-packages + -Wmissing-deriving-strategies exposed-modules: Stg.Syntax hs-source-dirs: lib - ghc-options: -Wall build-depends: base, bytestring, binary - default-language: Haskell2010 diff --git a/external-stg-syntax/hie.yaml b/external-stg-syntax/hie.yaml new file mode 100644 index 0000000..0ba10d6 --- /dev/null +++ b/external-stg-syntax/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "lib" + component: "lib:external-stg-syntax" diff --git a/external-stg-syntax/lib/Stg/Syntax.hs b/external-stg-syntax/lib/Stg/Syntax.hs index f720006..843d837 100644 --- a/external-stg-syntax/lib/Stg/Syntax.hs +++ b/external-stg-syntax/lib/Stg/Syntax.hs @@ -1,17 +1,26 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - module Stg.Syntax where -import GHC.Generics - -import qualified Data.ByteString as BS +import Data.Binary (Binary) +import Data.Bool (Bool (..), otherwise, (&&), (||)) +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import Data.Binary -import Data.List +import Data.Char (Char) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.Int (Int) +import Data.List (elemIndex, reverse, sum, zip, (!!), (++)) +import Data.Maybe (Maybe (..)) +import Data.Monoid ((<>)) +import Data.Ord (Ord (..), Ordering (..)) +import Data.Ratio (Rational) +import Data.String (String, IsString) + +import GHC.Generics (Generic) +import GHC.Num (Integer, Num (..)) +import GHC.Real (Integral (..), (^)) + +import Text.Read (Read (..), ReadS, lex) +import Text.Show (Show (..)) -- utility @@ -19,42 +28,51 @@ import Data.List newtype Id = Id {unId :: Binder} instance Eq Id where + (==) :: Id -> Id -> Bool (Id a) == (Id b) = binderUNameHash a == binderUNameHash b && binderUniqueName a == binderUniqueName b instance Ord Id where + compare :: Id -> Id -> Ordering compare (Id a) (Id b) = case compare (binderUNameHash a) (binderUNameHash b) of - EQ -> compare (binderUniqueName a) (binderUniqueName b) - x -> x + EQ -> compare (binderUniqueName a) (binderUniqueName b) + x -> x instance Show Id where + show :: Id -> String show (Id a) = BS8.unpack $ binderUniqueName a -- DataCon newtype DC = DC {unDC :: DataCon} instance Eq DC where + (==) :: DC -> DC -> Bool (DC a) == (DC b) = dcUNameHash a == dcUNameHash b && dcUniqueName a == dcUniqueName b instance Ord DC where + compare :: DC -> DC -> Ordering compare (DC a) (DC b) = case compare (dcUNameHash a) (dcUNameHash b) of - EQ -> compare (dcUniqueName a) (dcUniqueName b) - x -> x + EQ -> compare (dcUniqueName a) (dcUniqueName b) + x -> x instance Show DC where + show :: DC -> String show (DC a) = BS8.unpack $ dcUniqueName a -- TyCon newtype TC = TC {unTC :: TyCon} instance Eq TC where + (==) :: TC -> TC -> Bool (TC a) == (TC b) = tcUNameHash a == tcUNameHash b && tcUniqueName a == tcUniqueName b instance Ord TC where + compare :: TC -> TC -> Ordering compare (TC a) (TC b) = case compare (tcUNameHash a) (tcUNameHash b) of - EQ -> compare (tcUniqueName a) (tcUniqueName b) - x -> x + EQ -> compare (tcUniqueName a) (tcUniqueName b) + x -> x instance Show TC where + show :: TC -> String show (TC a) = BS8.unpack $ tcUniqueName a -- idinfo @@ -67,15 +85,17 @@ type Name = BS8.ByteString data Unique = Unique !Char !Int - deriving (Eq, Ord, Generic) + deriving stock (Eq, Ord, Generic) instance Read Unique where + readsPrec :: Int -> ReadS Unique readsPrec _d r = [ (Unique c (base62ToInt numStr), s) | (c : numStr, s) <- lex r ] instance Show Unique where + show :: Unique -> String show (Unique c n) = c : intToBase62 n base62ToInt :: String -> Int @@ -104,25 +124,25 @@ intToBase62 n_ = go n_ "" where data RealSrcSpan = RealSrcSpan' - { srcSpanFile :: !Name - , srcSpanSLine :: !Int - , srcSpanSCol :: !Int - , srcSpanELine :: !Int - , srcSpanECol :: !Int + { srcSpanFile :: !Name + , srcSpanSLine :: !Int + , srcSpanSCol :: !Int + , srcSpanELine :: !Int + , srcSpanECol :: !Int } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data BufSpan = BufSpan - { bufSpanStart :: !Int - , bufSpanEnd :: !Int + { bufSpanStart :: !Int + , bufSpanEnd :: !Int } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data SrcSpan = RealSrcSpan !RealSrcSpan !(Maybe BufSpan) | UnhelpfulSpan !UnhelpfulSpanReason - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data UnhelpfulSpanReason = UnhelpfulNoLocationInfo @@ -130,7 +150,7 @@ data UnhelpfulSpanReason | UnhelpfulInteractive | UnhelpfulGenerated | UnhelpfulOther !Name - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- tickish related @@ -142,7 +162,7 @@ data Tickish { sourceSpan :: RealSrcSpan , sourceName :: Name } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- type related @@ -164,7 +184,7 @@ data PrimRep | FloatRep | DoubleRep | VecRep Int PrimElemRep -- ^ A vector - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data PrimElemRep = Int8ElemRep @@ -177,7 +197,7 @@ data PrimElemRep | Word64ElemRep | FloatElemRep | DoubleElemRep - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) {- @@ -191,23 +211,25 @@ data Type = SingleValue !PrimRep | UnboxedTuple ![PrimRep] | PolymorphicRep - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- data con related newtype TyConId = TyConId Unique - deriving (Eq, Ord, Binary, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Binary) newtype DataConId = DataConId Unique - deriving (Eq, Ord, Binary, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Binary) -- raw data con data DataConRep = AlgDataCon ![PrimRep] | UnboxedTupleCon !Int - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data SDataCon = SDataCon @@ -217,7 +239,7 @@ data SDataCon , sdcWorker :: !SBinder , sdcDefLoc :: !SrcSpan } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data STyCon = STyCon @@ -226,50 +248,59 @@ data STyCon , stcDataCons :: ![SDataCon] , stcDefLoc :: !SrcSpan } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) newtype CutTyCon = CutTyCon {uncutTyCon :: TyCon } -instance Eq CutTyCon where _ == _ = True -instance Ord CutTyCon where compare _ _ = EQ -instance Show CutTyCon where show (CutTyCon tc) = "CutTyCon " ++ (BS8.unpack $ tcUniqueName tc) + +instance Eq CutTyCon where + (==) :: CutTyCon -> CutTyCon -> Bool + _ == _ = True + +instance Ord CutTyCon where + compare :: CutTyCon -> CutTyCon -> Ordering + compare _ _ = EQ + +instance Show CutTyCon where + show :: CutTyCon -> String + show (CutTyCon tc) = "CutTyCon " ++ BS8.unpack (tcUniqueName tc) -- user friendly data con data DataCon = DataCon - { dcName :: !Name - , dcId :: !DataConId - , dcUnitId :: !UnitId - , dcModule :: !ModuleName - , dcRep :: !DataConRep - , dcTyCon :: !CutTyCon - , dcWorker :: !Binder - , dcDefLoc :: !SrcSpan + { dcName :: !Name + , dcId :: !DataConId + , dcUnitId :: !UnitId + , dcModule :: !ModuleName + , dcRep :: !DataConRep + , dcTyCon :: !CutTyCon + , dcWorker :: !Binder + , dcDefLoc :: !SrcSpan -- optimization - , dcUniqueName :: {-# UNPACK #-} !Name - , dcUNameHash :: {-# UNPACK #-} !Int + , dcUniqueName :: {-# UNPACK #-} !Name + , dcUNameHash :: {-# UNPACK #-} !Int } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data TyCon = TyCon - { tcName :: !Name - , tcId :: !TyConId - , tcUnitId :: !UnitId - , tcModule :: !ModuleName - , tcDataCons :: ![DataCon] - , tcDefLoc :: !SrcSpan + { tcName :: !Name + , tcId :: !TyConId + , tcUnitId :: !UnitId + , tcModule :: !ModuleName + , tcDataCons :: ![DataCon] + , tcDefLoc :: !SrcSpan -- optimization - , tcUniqueName :: {-# UNPACK #-} !Name - , tcUNameHash :: {-# UNPACK #-} !Int + , tcUniqueName :: {-# UNPACK #-} !Name + , tcUNameHash :: {-# UNPACK #-} !Int } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- id info data CbvMark = MarkedCbv | NotMarkedCbv - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data IdDetails = VanillaId @@ -285,65 +316,69 @@ data IdDetails | JoinId Int (Maybe [CbvMark]) | WorkerLikeId [CbvMark] | RepPolyId - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- stg expr related newtype UnitId = UnitId Name - deriving (Eq, Ord, Binary, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Binary) getUnitId :: UnitId -> Name getUnitId (UnitId n) = n newtype ModuleName = ModuleName Name - deriving (Eq, Ord, Binary, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Binary) + deriving newtype (IsString) getModuleName :: ModuleName -> Name getModuleName (ModuleName n) = n newtype BinderId = BinderId Unique - deriving (Eq, Ord, Binary, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (Binary) data SBinder = SBinder - { sbinderName :: !Name - , sbinderId :: !BinderId - , sbinderType :: !Type - , sbinderTypeSig :: !Name - , sbinderScope :: !Scope - , sbinderDetails :: !IdDetails - , sbinderInfo :: !IdInfo - , sbinderDefLoc :: !SrcSpan + { sbinderName :: !Name + , sbinderId :: !BinderId + , sbinderType :: !Type + , sbinderTypeSig :: !Name + , sbinderScope :: !Scope + , sbinderDetails :: !IdDetails + , sbinderInfo :: !IdInfo + , sbinderDefLoc :: !SrcSpan } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Binder = Binder - { binderName :: !Name - , binderId :: !BinderId - , binderType :: !Type - , binderTypeSig :: !Name - , binderScope :: !Scope - , binderDetails :: !IdDetails - , binderInfo :: !IdInfo - , binderDefLoc :: !SrcSpan - , binderUnitId :: !UnitId - , binderModule :: !ModuleName - , binderTopLevel :: !Bool + { binderName :: !Name + , binderId :: !BinderId + , binderType :: !Type + , binderTypeSig :: !Name + , binderScope :: !Scope + , binderDetails :: !IdDetails + , binderInfo :: !IdInfo + , binderDefLoc :: !SrcSpan + , binderUnitId :: !UnitId + , binderModule :: !ModuleName + , binderTopLevel :: !Bool -- optimization - , binderUniqueName :: {-# UNPACK #-} !Name - , binderUNameHash :: {-# UNPACK #-} !Int + , binderUniqueName :: {-# UNPACK #-} !Name + , binderUNameHash :: {-# UNPACK #-} !Int } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Scope = ModulePublic -- ^ visible for every haskell module | ModulePrivate -- ^ visible for a single haskell module | ClosurePrivate -- ^ visible for expression body - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) mkTyConUniqueName :: UnitId -> ModuleName -> STyCon -> Name mkTyConUniqueName unitId modName STyCon{..} = getUnitId unitId <> "_" <> getModuleName modName <> "." <> stcName @@ -380,12 +415,12 @@ data LitNumType | LitNumWord16 -- ^ @Word16#@ - exactly 16 bits | LitNumWord32 -- ^ @Word32#@ - exactly 32 bits | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data LabelSpec = FunctionLabel !(Maybe Int) -- only for stdcall convention | DataLabel - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Lit = LitChar !Char @@ -396,24 +431,24 @@ data Lit | LitLabel !BS8.ByteString LabelSpec | LitNumber !LitNumType !Integer | LitRubbish !Type - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- | A top-level binding. data TopBinding' idBnd idOcc dcOcc tcOcc -- See Note [CoreSyn top-level string literals] = StgTopLifted (Binding' idBnd idOcc dcOcc tcOcc) | StgTopStringLit idBnd BS.ByteString - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Binding' idBnd idOcc dcOcc tcOcc = StgNonRec idBnd (Rhs' idBnd idOcc dcOcc tcOcc) | StgRec [(idBnd, Rhs' idBnd idOcc dcOcc tcOcc)] - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Arg' idOcc = StgVarArg idOcc | StgLitArg !Lit - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Expr' idBnd idOcc dcOcc tcOcc = StgApp @@ -452,17 +487,17 @@ data Expr' idBnd idOcc dcOcc tcOcc | StgTick Tickish (Expr' idBnd idOcc dcOcc tcOcc) -- sub expression - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data AltType' tcOcc = PolyAlt | MultiValAlt !Int | PrimAlt !PrimRep | AlgAlt tcOcc - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -data UpdateFlag = ReEntrant | Updatable | SingleEntry - deriving (Eq, Ord, Generic, Show) +data UpdateFlag = ReEntrant | Updatable | SingleEntry | JumpedTo + deriving stock (Eq, Ord, Generic, Show) data Rhs' idBnd idOcc dcOcc tcOcc = StgRhsClosure @@ -475,7 +510,7 @@ data Rhs' idBnd idOcc dcOcc tcOcc | StgRhsCon dcOcc -- DataCon [Arg' idOcc] -- Args - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Alt' idBnd idOcc dcOcc tcOcc = Alt @@ -483,75 +518,75 @@ data Alt' idBnd idOcc dcOcc tcOcc , altBinders :: [idBnd] , altRHS :: Expr' idBnd idOcc dcOcc tcOcc } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data AltCon' dcOcc = AltDataCon dcOcc | AltLit !Lit | AltDefault - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data Safety = PlaySafe | PlayInterruptible | PlayRisky - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data SourceText = SourceText !BS8.ByteString | NoSourceText - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data CCallTarget = StaticTarget !SourceText !BS8.ByteString !(Maybe UnitId) !Bool {- is function -} | DynamicTarget - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data ForeignCall = ForeignCall - { foreignCTarget :: !CCallTarget - , foreignCConv :: !CCallConv - , foreignCSafety :: !Safety + { foreignCTarget :: !CCallTarget + , foreignCConv :: !CCallConv + , foreignCSafety :: !Safety } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data PrimCall = PrimCall !BS8.ByteString !UnitId - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data StgOp = StgPrimOp !Name | StgPrimCallOp !PrimCall | StgFCallOp !ForeignCall - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- foreign export stubs data Header = Header !SourceText !Name - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data ForeignImport = CImport !CCallConv !Safety !(Maybe Header) !CImportSpec !SourceText - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data CImportSpec = CLabel !Name | CFunction !CCallTarget | CWrapper - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data ForeignExport = CExport !CExportSpec !SourceText - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data CExportSpec = CExportStatic !SourceText !Name !CCallConv - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data StubImpl = StubImplImportCWrapper !Name !(Maybe Int) !Bool !Name ![Name] | StubImplImportCApi !Name ![(Maybe Header, BS8.ByteString, Char)] - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data StubDecl' idOcc = StubDeclImport !ForeignImport !(Maybe StubImpl) | StubDeclExport !ForeignExport idOcc !BS8.ByteString - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data ModuleLabelKind = MLK_Initializer Name @@ -559,39 +594,39 @@ data ModuleLabelKind | MLK_Finalizer Name | MLK_FinalizerArray | MLK_IPEBuffer - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data ModuleCLabel = ModuleCLabel !UnitId !ModuleName !ModuleLabelKind - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) data ForeignStubs' idOcc = NoStubs | ForeignStubs - { fsCHeader :: !BS8.ByteString - , fsCSource :: !BS8.ByteString - , fsInitializers :: ![ModuleCLabel] - , fsFinalizers :: ![ModuleCLabel] - , fsDecls :: ![StubDecl' idOcc] + { fsCHeader :: !BS8.ByteString + , fsCSource :: !BS8.ByteString + , fsInitializers :: ![ModuleCLabel] + , fsFinalizers :: ![ModuleCLabel] + , fsDecls :: ![StubDecl' idOcc] } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- the whole module data Module' idBnd idOcc dcOcc tcBnd tcOcc = Module - { modulePhase :: !BS8.ByteString - , moduleUnitId :: !UnitId - , moduleName :: !ModuleName - , moduleSourceFilePath :: !(Maybe Name) -- HINT: RealSrcSpan's source file refers to this value - , moduleForeignStubs :: !(ForeignStubs' idOcc) - , moduleHasForeignExported :: !Bool - , moduleDependency :: ![(UnitId, [ModuleName])] - , moduleExternalTopIds :: ![(UnitId, [(ModuleName, [idBnd])])] - , moduleTyCons :: ![(UnitId, [(ModuleName, [tcBnd])])] - , moduleTopBindings :: ![TopBinding' idBnd idOcc dcOcc tcOcc] + { modulePhase :: !BS8.ByteString + , moduleUnitId :: !UnitId + , moduleName :: !ModuleName + , moduleSourceFilePath :: !(Maybe Name) -- HINT: RealSrcSpan's source file refers to this value + , moduleForeignStubs :: !(ForeignStubs' idOcc) + , moduleHasForeignExported :: !Bool + , moduleDependency :: ![(UnitId, [ModuleName])] + , moduleExternalTopIds :: ![(UnitId, [(ModuleName, [idBnd])])] + , moduleTyCons :: ![(UnitId, [(ModuleName, [tcBnd])])] + , moduleTopBindings :: ![TopBinding' idBnd idOcc dcOcc tcOcc] } - deriving (Eq, Ord, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) -- convenience layers: raw and user friendly diff --git a/external-stg/Setup.hs b/external-stg/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/external-stg/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/external-stg/app/ext-stg.hs b/external-stg/app/ext-stg.hs index 7943fb1..38fae82 100644 --- a/external-stg/app/ext-stg.hs +++ b/external-stg/app/ext-stg.hs @@ -1,12 +1,24 @@ -import Control.Monad -import Data.List +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad -import Options.Applicative -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text.IO as T +import Data.Bool (not) +import qualified Data.ByteString.Lazy as BSL +import Data.Function (($), (.)) +import Data.List (isSuffixOf) +import Data.Monoid (Monoid (..), (<>)) +import Data.String (String) +import qualified Data.Text.IO as T +import Data.Tuple (fst) -import Stg.Pretty -import Stg.IO +import Options.Applicative (CommandFields, InfoMod, Mod, Parser) +import Options.Applicative.Builder (argument, command, help, info, long, metavar, progDesc, str, subparser, + switch) +import Options.Applicative.Extra (execParser, helper) + +import Stg.IO (decodeStgbin, modpakStgbinPath, readModpakL) +import Stg.Pretty (Config (..), pShowWithConfig, pprModule) + +import System.IO (FilePath, IO) modes :: Parser (IO ()) modes = subparser @@ -25,9 +37,9 @@ modes = subparser where run fname hideTickish = do dump <- case () of - _ | isSuffixOf "modpak" fname -> Stg.IO.readModpakL fname modpakStgbinPath decodeStgbin - _ | isSuffixOf "stgbin" fname -> decodeStgbin <$> BSL.readFile fname - _ -> fail "unknown file format" + _ | "modpak" `isSuffixOf` fname -> readModpakL fname modpakStgbinPath decodeStgbin + _ | "stgbin" `isSuffixOf` fname -> decodeStgbin <$> BSL.readFile fname + _ -> fail "unknown file format" let cfg = Config { cfgPrintTickish = not hideTickish } diff --git a/external-stg/app/mkfullpak.hs b/external-stg/app/mkfullpak.hs index c2bd00f..853f003 100644 --- a/external-stg/app/mkfullpak.hs +++ b/external-stg/app/mkfullpak.hs @@ -1,9 +1,17 @@ -{-# LANGUAGE RecordWildCards #-} -import System.FilePath -import Options.Applicative -import Data.Semigroup ((<>)) +import Control.Applicative (Applicative (..), (<$>), (<**>)) -import Stg.Fullpak +import Data.Bool (Bool) +import Data.Monoid (Monoid (..)) +import Data.Semigroup ((<>)) + +import Options.Applicative (Parser) +import Options.Applicative.Builder (argument, help, info, long, metavar, short, str, switch) +import Options.Applicative.Extra (execParser, helper) + +import Stg.Fullpak (mkFullpak) + +import System.FilePath (FilePath, (-<.>)) +import System.IO (IO) data FullpakOptions = FullpakOptions diff --git a/external-stg/app/stgapp.hs b/external-stg/app/stgapp.hs index 65ed43d..ac8cdc5 100644 --- a/external-stg/app/stgapp.hs +++ b/external-stg/app/stgapp.hs @@ -1,36 +1,50 @@ -{-# LANGUAGE ScopedTypeVariables, RecordWildCards, OverloadedStrings #-} - -import Control.Monad -import Data.Maybe -import Data.List (isSuffixOf) -import Data.Monoid -import Data.Ord -import Data.Semigroup ((<>)) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Set as Set -import qualified Data.Map as Map -import System.Directory -import System.FilePath -import System.IO -import System.Posix.DynamicLinker -import Text.Printf -import Foreign - -import Options.Applicative - -import Stg.Syntax -import Stg.Analysis.Closure -import Stg.Analysis.ForeignInfo -import Stg.Program -import Stg.GHC.Symbols -import Stg.Foreign.Linker +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Functor (..), MonadFail (..), filterM, forM_, join, mapM_) + +import Data.Bool (Bool (..)) +import qualified Data.ByteString.Char8 as BS8 +import Data.Eq (Eq (..)) +import Data.Function (flip, ($), (.)) +import Data.List (concatMap, isSuffixOf, length, take, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), isNothing, maybeToList) +import Data.Monoid (Monoid (..), (<>)) +import Data.Ord (Ord (..)) +import qualified Data.Set as Set +import Data.String (String) + +import Foreign (nullFunPtr) + +import GHC.Num (Integer, Num (..)) + +import Options.Applicative (CommandFields, InfoMod, Mod, Parser) +import Options.Applicative.Builder (argument, command, help, info, metavar, progDesc, str, subparser) +import Options.Applicative.Extra (execParser, helper) + +import Stg.Analysis.Closure (getAllClosures) +import Stg.Analysis.ForeignInfo (ForeignInfo (..), getForeignInfos) +import Stg.Foreign.Linker (getExtStgWorkDirectory, linkForeignCbitsSharedLib) +import Stg.GHC.Symbols (getSymbolName, handledRTSSymbols, rtsSymbols) +import Stg.Program (StgModuleInfo (..), getAppModuleMapping, getFullpakModules, + getGhcStgAppModules, getJSONModules) +import Stg.Syntax (CCallTarget (..), ForeignCall (..), ForeignStubs' (..), Lit (..), Module, + Module' (..), PrimCall (..), StubDecl' (..), StubImpl (..), getModuleName, + getUnitId) + +import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute) +import System.FilePath (FilePath, takeExtension, (-<.>), ()) +import System.IO (IO, IOMode (..), hPutStrLn, putStrLn, withFile) +import System.Posix.DynamicLinker (RTLDFlags (..), c_dlsym, dlopen, packDL) + +import Text.Printf (printf) +import Text.Show (Show (..)) loadModules :: FilePath -> IO [Module] loadModules fname = case () of - _ | isSuffixOf "fullpak" fname -> Stg.Program.getFullpakModules fname - _ | isSuffixOf "ghc_stgapp" fname -> Stg.Program.getGhcStgAppModules fname - _ | isSuffixOf "json" fname -> Stg.Program.getJSONModules fname - _ -> fail "unknown file format" + _ | "fullpak" `isSuffixOf` fname -> getFullpakModules fname + _ | "ghc_stgapp" `isSuffixOf` fname -> getGhcStgAppModules fname + _ | "json" `isSuffixOf` fname -> getJSONModules fname + _ -> fail "unknown file format" modes :: Parser (IO ()) modes = subparser @@ -107,7 +121,7 @@ modes = subparser symbols = Set.fromList $ [n | LitLabel n _ <- Map.keys fiLitLabels] ++ [n | PrimCall n _ <- Map.keys fiPrimCalls] ++ - [n | StaticTarget _ n _ _ <- map foreignCTarget $ Map.keys fiForeignCalls] + [n | StaticTarget _ n _ _ <- foreignCTarget <$> Map.keys fiForeignCalls] printf "foreign symbols: %d\n" (Set.size symbols) mapM_ BS8.putStrLn $ Set.toList symbols @@ -130,8 +144,7 @@ modes = subparser moduleList <- loadModules fname let ForeignInfo{..} = getForeignInfos moduleList printf "used literals: %d\n" (Map.size fiLiterals) - forM_ (Map.toList fiLiterals) $ \(lit, count) -> do - printf "%-10d %s\n" count (show lit) + forM_ (Map.toList fiLiterals) $ \(lit, count) -> printf "%-10d %s\n" count (show lit) stringsMode :: Parser (IO ()) stringsMode = @@ -141,8 +154,7 @@ modes = subparser moduleList <- loadModules fname let ForeignInfo{..} = getForeignInfos moduleList printf "used top level strings: %d\n" (Map.size fiTopStrings) - forM_ (Map.toList fiTopStrings) $ \(str, count) -> do - printf "%-10d %s\n" count (show str) + forM_ (Map.toList fiTopStrings) $ \(str', count) -> printf "%-10d %s\n" count (show str') undefMode :: Parser (IO ()) undefMode = @@ -153,30 +165,29 @@ modes = subparser moduleList <- loadModules fname let ignoredSymbols = Set.fromList $ [ n - | ForeignStubs _ _ _ _ l <- map moduleForeignStubs moduleList + | ForeignStubs _ _ _ _ l <- fmap moduleForeignStubs moduleList , StubDeclImport _ (Just (StubImplImportCWrapper n _ _ _ _)) <- l -- HINT: these symbols are used only by "createAdjustor" that does not dereference the symbol - ] ++ map BS8.pack handledRTSSymbols + ] ++ fmap BS8.pack handledRTSSymbols let ForeignInfo{..} = getForeignInfos moduleList symbols = Set.fromList $ [n | LitLabel n _ <- Map.keys fiLitLabels] ++ [n | PrimCall n _ <- Map.keys fiPrimCalls] ++ - [n | StaticTarget _ n _ _ <- map foreignCTarget $ Map.keys fiForeignCalls] + [n | StaticTarget _ n _ _ <- foreignCTarget <$> Map.keys fiForeignCalls] -- get known symbols from .cbits.so soName <- makeAbsolute (fname -<.> ".cbits.so") dl <- dlopen soName [{-RTLD_NOW-}RTLD_LAZY, RTLD_LOCAL] - undefList <- flip filterM (Set.toList symbols) $ \sym -> do - BS8.useAsCString sym $ \s -> do - symPtr <- c_dlsym (packDL dl) s - pure (symPtr == nullFunPtr) + undefList <- flip filterM (Set.toList symbols) $ \sym -> BS8.useAsCString sym $ \s -> do + symPtr <- c_dlsym (packDL dl) s + pure (symPtr == nullFunPtr) let undefSet = Set.fromList undefList Set.\\ ignoredSymbols printf "undefined symbols: %d\n" (Set.size undefSet) mapM_ BS8.putStrLn $ Set.toList undefSet - let nonRTSUndefSet = undefSet Set.\\ Set.fromList (map (BS8.pack . getSymbolName) rtsSymbols) + let nonRTSUndefSet = undefSet Set.\\ Set.fromList (fmap (BS8.pack . getSymbolName) rtsSymbols) printf "\nnon RTS undefined symbols: %d\n" (Set.size nonRTSUndefSet) mapM_ BS8.putStrLn $ Set.toList nonRTSUndefSet @@ -185,15 +196,13 @@ modes = subparser linkMode = run <$> fullpakFile where - run fname = case isSuffixOf "ghc_stgapp" fname of - False -> do - printf "linking is not supported for %s\n" . show $ takeExtension fname - True -> do - workDir <- getExtStgWorkDirectory fname - createDirectoryIfMissing True workDir - let soName = workDir "cbits.so" - printf "linking %s\n" soName - linkForeignCbitsSharedLib fname + run fname = if "ghc_stgapp" `isSuffixOf` fname then (do + workDir <- getExtStgWorkDirectory fname + createDirectoryIfMissing True workDir + let soName = workDir "cbits.so" + printf "linking %s\n" soName + linkForeignCbitsSharedLib fname) else (do + printf "linking is not supported for %s\n" . show $ takeExtension fname) hiListMode :: Parser (IO ()) hiListMode = @@ -206,9 +215,7 @@ modes = subparser forM_ moduleInfoList $ \StgModuleInfo{..} -> do let hiName = take (length modModpakPath - 8) modModpakPath ++ "hi" ok <- doesFileExist hiName - case ok of - True -> printf "OK: %s\n" modModuleName - False -> printf "MISSING: %s\n" hiName + (if ok then printf "OK: %s\n" modModuleName else printf "MISSING: %s\n" hiName) srcpathMode :: Parser (IO ()) srcpathMode = @@ -225,17 +232,15 @@ modes = subparser (BS8.unpack srcPath) -- report empty moduleSourceFilePath - forM_ [m | m <- moduleList, isNothing $ moduleSourceFilePath m] $ \m -> do - printf "missing source filepath for: %s %s\n" (BS8.unpack $ getUnitId $ moduleUnitId m) (BS8.unpack $ getModuleName $ moduleName m) + forM_ [m | m <- moduleList, isNothing $ moduleSourceFilePath m] $ \m -> printf "missing source filepath for: %s %s\n" (BS8.unpack $ getUnitId $ moduleUnitId m) (BS8.unpack $ getModuleName $ moduleName m) -- report ambiguous moduleSourceFilePath - let moduleMaps = [Map.singleton srcPath (1, [m]) | m <- moduleList, srcPath <- maybeToList $ moduleSourceFilePath m] + let moduleMaps = [Map.singleton srcPath (1 :: Integer, [m]) | m <- moduleList, srcPath <- maybeToList $ moduleSourceFilePath m] duplicates = Map.filter (\(n, _) -> n > 1) $ Map.unionsWith (\(n1, l1) (n2, l2) -> (n1 + n2, l1 ++ l2)) moduleMaps - forM_ (Map.toList duplicates) $ \(srcPath, (_, mods)) -> forM_ mods $ \m -> do - printf "duplicate source filepath: %s %s %s\n" - (BS8.unpack $ getUnitId $ moduleUnitId m) - (BS8.unpack $ getModuleName $ moduleName m) - (BS8.unpack srcPath) + forM_ (Map.toList duplicates) $ \(srcPath, (_, mods)) -> forM_ mods $ \m -> printf "duplicate source filepath: %s %s %s\n" + (BS8.unpack $ getUnitId $ moduleUnitId m) + (BS8.unpack $ getModuleName $ moduleName m) + (BS8.unpack srcPath) main :: IO () main = join $ execParser $ info (helper <*> modes) mempty diff --git a/external-stg/external-stg.cabal b/external-stg/external-stg.cabal index c3acbba..637f355 100644 --- a/external-stg/external-stg.cabal +++ b/external-stg/external-stg.cabal @@ -1,38 +1,39 @@ +cabal-version: 3.14 name: external-stg version: 0.1.0.1 synopsis: A library to dump GHC's STG representation. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Csaba Hruska maintainer: csaba.hruska@gmail.com copyright: (c) 2018 Csaba Hruska category: Development build-type: Simple -tested-with: GHC==8.8.3 -cabal-version: >=1.10 + +common lang + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards + ghc-options: + -Wall + -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Widentities + -Wunused-packages + -Wmissing-deriving-strategies + library - exposed-modules: - Stg.Pretty - Stg.IRLocation - Stg.Tickish - Stg.Reconstruct - Stg.Deconstruct - Stg.Fullpak - Stg.Program - Stg.IO - Stg.GHC.Symbols - Stg.JSON - Stg.Analysis.Closure - Stg.Analysis.ForeignInfo - Stg.Analysis.LiveVariable - Stg.Foreign.Linker - Stg.Foreign.Stubs + import: lang hs-source-dirs: lib - ghc-options: -Wall cpp-options: -DEXTERNAL_STG_PACKAGE - other-extensions: GeneralizedNewtypeDeriving build-depends: base, bytestring, filemanip, @@ -41,52 +42,61 @@ library process, binary, containers, - transformers, mtl, unordered-containers, hashable, - ansi-wl-pprint, final-pretty-printer, zip, text, aeson, yaml, external-stg-syntax - default-language: Haskell2010 + exposed-modules: + Stg.Pretty + Stg.IRLocation + Stg.Tickish + Stg.Reconstruct + Stg.Deconstruct + Stg.Fullpak + Stg.Program + Stg.IO + Stg.GHC.Symbols + Stg.JSON + Stg.Analysis.Closure + Stg.Analysis.ForeignInfo + Stg.Analysis.LiveVariable + Stg.Foreign.Linker + Stg.Foreign.Stubs executable ext-stg + import: lang hs-source-dirs: app main-is: ext-stg.hs build-depends: base < 5.0, external-stg, - external-stg-syntax, - ansi-wl-pprint, bytestring, text, optparse-applicative - default-language: Haskell2010 executable stgapp + import: lang hs-source-dirs: app main-is: stgapp.hs build-depends: base < 5.0, containers, filepath, directory, - yaml, unix, - process, bytestring, external-stg, external-stg-syntax, optparse-applicative - default-language: Haskell2010 executable mkfullpak + import: lang hs-source-dirs: app main-is: mkfullpak.hs build-depends: base , filepath , optparse-applicative , external-stg - default-language: Haskell2010 diff --git a/external-stg/hie.yaml b/external-stg/hie.yaml new file mode 100644 index 0000000..d7a603f --- /dev/null +++ b/external-stg/hie.yaml @@ -0,0 +1,13 @@ +cradle: + cabal: + - path: "lib" + component: "lib:external-stg" + + - path: "app/ext-stg.hs" + component: "external-stg:exe:ext-stg" + + - path: "app/stgapp.hs" + component: "external-stg:exe:stgapp" + + - path: "app/mkfullpak.hs" + component: "external-stg:exe:mkfullpak" diff --git a/external-stg/lib/Stg/Analysis/Closure.hs b/external-stg/lib/Stg/Analysis/Closure.hs index 6e54379..4192f84 100644 --- a/external-stg/lib/Stg/Analysis/Closure.hs +++ b/external-stg/lib/Stg/Analysis/Closure.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} module Stg.Analysis.Closure (getAllClosures) where -import Stg.Syntax +import Data.List (concatMap, (++)) +import Data.Tuple (uncurry) + +import Stg.Syntax (Alt, Alt' (..), Binder, Binding, Binding' (..), Expr, Expr' (..), Id (..), Module, + Module' (..), Rhs, Rhs' (..), TopBinding, TopBinding' (..)) getAllClosures :: Module -> [(Id, Rhs)] getAllClosures = visitModule @@ -32,5 +35,5 @@ visitExpr = \case visitRhs :: Binder -> Rhs -> [(Id, Rhs)] visitRhs b rhs = case rhs of - StgRhsClosure _ _ _ expr -> (Id b, rhs) : visitExpr expr - _ -> [] + StgRhsClosure _ _ _ expr -> (Id b, rhs) : visitExpr expr + _ -> [] diff --git a/external-stg/lib/Stg/Analysis/ForeignInfo.hs b/external-stg/lib/Stg/Analysis/ForeignInfo.hs index 40e13f3..3750453 100644 --- a/external-stg/lib/Stg/Analysis/ForeignInfo.hs +++ b/external-stg/lib/Stg/Analysis/ForeignInfo.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} module Stg.Analysis.ForeignInfo ( ForeignInfo(..) , getForeignInfo @@ -7,27 +6,38 @@ module Stg.Analysis.ForeignInfo , emptyForeignInfo ) where -import Control.Monad -import Control.Monad.State +import Control.Applicative (Applicative (..)) +import Control.Monad (mapM_) +import Control.Monad.State (State, execState, gets, modify') -import Data.Set (Set) -import qualified Data.Set as Set +import Data.Eq (Eq) +import Data.Function (($), (.)) +import Data.Int (Int) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord (Ord) +import Data.Tuple (snd) -import Data.Map (Map) -import qualified Data.Map as Map +import GHC.Num (Num (..)) -import Stg.Syntax +import Prelude (($!)) + +import Stg.Syntax (Alt, Alt' (..), Arg, Arg' (..), Binding, Binding' (..), Expr, Expr' (..), + ForeignCall, Lit (LitLabel), Module, Module' (..), Name, PrimCall, Rhs, Rhs' (..), + StgOp (..), TopBinding, TopBinding' (..)) + +import Text.Show (Show) data ForeignInfo = ForeignInfo - { fiLitLabels :: !(Map Lit Int) - , fiPrimCalls :: !(Map PrimCall Int) - , fiForeignCalls :: !(Map ForeignCall Int) - , fiPrimOps :: !(Map Name Int) - , fiLiterals :: !(Map Lit Int) - , fiTopStrings :: !(Map Name Int) + { fiLitLabels :: !(Map Lit Int) + , fiPrimCalls :: !(Map PrimCall Int) + , fiForeignCalls :: !(Map ForeignCall Int) + , fiPrimOps :: !(Map Name Int) + , fiLiterals :: !(Map Lit Int) + , fiTopStrings :: !(Map Name Int) } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) emptyForeignInfo :: ForeignInfo emptyForeignInfo = ForeignInfo @@ -121,9 +131,9 @@ visitExpr e = case e of StgOpApp op args _ _ -> do mapM_ visitArg args case op of - StgPrimOp p -> addPrimOp p - StgPrimCallOp pc -> addPrimCall pc - StgFCallOp fc -> addForeignCall fc + StgPrimOp p -> addPrimOp p + StgPrimCallOp pc -> addPrimCall pc + StgFCallOp fc -> addForeignCall fc StgCase expr _ _ alts -> do visitExpr expr @@ -151,5 +161,5 @@ visitLit :: Lit -> M () visitLit l = do addLit l case l of - LitLabel{} -> addLitLabel l - _ -> pure () + LitLabel{} -> addLitLabel l + _ -> pure () diff --git a/external-stg/lib/Stg/Analysis/LiveVariable.hs b/external-stg/lib/Stg/Analysis/LiveVariable.hs index 3c2e818..fd8672c 100644 --- a/external-stg/lib/Stg/Analysis/LiveVariable.hs +++ b/external-stg/lib/Stg/Analysis/LiveVariable.hs @@ -1,10 +1,20 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} module Stg.Analysis.LiveVariable (annotateWithLiveVariables) where -import Data.Set (Set) -import qualified Data.Set as Set +import Control.Monad (Functor (..)) -import Stg.Syntax +import Data.Bool (not) +import Data.Function (($), (.)) +import Data.List (foldr, unzip, (++)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Tuple (fst) + +import GHC.Err (error) + +import Stg.Syntax (Alt, Alt' (..), Arg' (..), Binder (..), Binding, Binding' (..), Expr, Expr' (..), + Id (..), Module, Module' (..), Rhs, Rhs' (..), TopBinding, TopBinding' (..)) + +import Text.Show (Show (..)) type UsedLocal = Set Id @@ -13,17 +23,17 @@ annotateWithLiveVariables = visitModule -- HINT: used local bindings mkUsedLocal :: [Binder] -> UsedLocal -mkUsedLocal l = Set.fromList [Id b | b <- l, binderTopLevel b == False] +mkUsedLocal l = Set.fromList [Id b | b <- l, not (binderTopLevel b)] remove :: [Binder] -> UsedLocal -> UsedLocal -remove l u = foldr (\b -> Set.delete (Id b)) u l +remove l u = foldr (Set.delete . Id) u l visitAlt :: Alt -> (UsedLocal, Alt) visitAlt a@Alt{..} = (remove altBinders u, a {altRHS = expr}) where (u, expr) = visitExpr altRHS visitModule :: Module -> Module -visitModule m@Module{..} = m {moduleTopBindings = map visitTopBinding moduleTopBindings} +visitModule m@Module{..} = m {moduleTopBindings = fmap visitTopBinding moduleTopBindings} visitTopBinding :: TopBinding -> TopBinding visitTopBinding t = case t of @@ -49,7 +59,7 @@ visitRhs = \case StgRhsClosure _ update args expr -> let (u, expr') = visitExpr expr u' = remove args u - freeVars = map unId $ Set.toList u' + freeVars = fmap unId $ Set.toList u' in (u', StgRhsClosure freeVars update args expr') StgRhsCon dc args -> (u, StgRhsCon dc args) where u = mkUsedLocal [b | StgVarArg b <- args] @@ -66,7 +76,7 @@ visitExpr e = case e of StgCase expr b aty alts -> let (u0, expr') = visitExpr expr - (uA, alts') = unzip $ map visitAlt alts + (uA, alts') = unzip $ fmap visitAlt alts u = remove [b] $ Set.unions $ u0 : uA in (u, StgCase expr' b aty alts') @@ -89,4 +99,4 @@ visitExpr e = case e of getBindingBinders :: Binding -> [Binder] getBindingBinders = \case StgNonRec b _ -> [b] - StgRec l -> map fst l + StgRec l -> fmap fst l diff --git a/external-stg/lib/Stg/Deconstruct.hs b/external-stg/lib/Stg/Deconstruct.hs index 7b6dad8..13c760d 100644 --- a/external-stg/lib/Stg/Deconstruct.hs +++ b/external-stg/lib/Stg/Deconstruct.hs @@ -1,7 +1,15 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} module Stg.Deconstruct (deconModule) where -import Stg.Syntax +import Control.Monad (Functor (..)) + +import Data.Function (($)) + +import Stg.Syntax (Alt, Alt' (..), AltCon, AltCon' (..), AltType, AltType' (..), Arg, Arg' (..), + Binder (..), BinderId, Binding, Binding' (..), DataCon (..), DataConId, Expr, + Expr' (..), ForeignStubs, ForeignStubs' (..), Module, Module' (..), Rhs, Rhs' (..), + SAlt, SAltCon, SAltType, SArg, SBinder (..), SBinding, SDataCon (..), SExpr, + SForeignStubs, SModule, SRhs, SStubDecl, STopBinding, STyCon (..), StubDecl, + StubDecl' (..), TopBinding, TopBinding' (..), TyCon (..), TyConId) deconModule :: Module -> SModule deconModule Module{..} = smod where @@ -13,9 +21,9 @@ deconModule Module{..} = smod where , moduleForeignStubs = deconForeignStubs moduleForeignStubs , moduleHasForeignExported = moduleHasForeignExported , moduleDependency = moduleDependency - , moduleExternalTopIds = [(uid, [(m, map deconIdBnd ids) | (m, ids) <- mods]) | (uid, mods) <- moduleExternalTopIds] - , moduleTyCons = [(uid, [(m, map deconTcBnd tcs) | (m, tcs) <- mods]) | (uid, mods) <- moduleTyCons] - , moduleTopBindings = map deconTopBinding moduleTopBindings + , moduleExternalTopIds = [(uid, [(m, fmap deconIdBnd ids) | (m, ids) <- mods]) | (uid, mods) <- moduleExternalTopIds] + , moduleTyCons = [(uid, [(m, fmap deconTcBnd tcs) | (m, tcs) <- mods]) | (uid, mods) <- moduleTyCons] + , moduleTopBindings = fmap deconTopBinding moduleTopBindings } deconIdBnd :: Binder -> SBinder @@ -36,7 +44,7 @@ deconTcBnd TyCon{..} = STyCon { stcName = tcName , stcId = tcId - , stcDataCons = map deconDcBnd tcDataCons + , stcDataCons = fmap deconDcBnd tcDataCons , stcDefLoc = tcDefLoc } @@ -71,8 +79,8 @@ deconBinding = \case deconRhs :: Rhs -> SRhs deconRhs = \case - StgRhsClosure idOccList uf idBndList e -> StgRhsClosure (map deconIdOcc idOccList) uf (map deconIdBnd idBndList) (deconExpr e) - StgRhsCon dcOcc args -> StgRhsCon (deconDcOcc dcOcc) (map deconArg args) + StgRhsClosure idOccList uf idBndList e -> StgRhsClosure (fmap deconIdOcc idOccList) uf (fmap deconIdBnd idBndList) (deconExpr e) + StgRhsCon dcOcc args -> StgRhsCon (deconDcOcc dcOcc) (fmap deconArg args) deconArg :: Arg -> SArg deconArg = \case @@ -81,11 +89,11 @@ deconArg = \case deconExpr :: Expr -> SExpr deconExpr = \case - StgApp idOcc args -> StgApp (deconIdOcc idOcc) (map deconArg args) + StgApp idOcc args -> StgApp (deconIdOcc idOcc) (fmap deconArg args) StgLit lit -> StgLit lit - StgConApp dcOcc args ts -> StgConApp (deconDcOcc dcOcc) (map deconArg args) ts - StgOpApp op args t mTc -> StgOpApp op (map deconArg args) t (fmap deconTcOcc mTc) - StgCase e idBnd at alts -> StgCase (deconExpr e) (deconIdBnd idBnd) (deconAltType at) (map deconAlt alts) + StgConApp dcOcc args ts -> StgConApp (deconDcOcc dcOcc) (fmap deconArg args) ts + StgOpApp op args t mTc -> StgOpApp op (fmap deconArg args) t (fmap deconTcOcc mTc) + StgCase e idBnd at alts -> StgCase (deconExpr e) (deconIdBnd idBnd) (deconAltType at) (fmap deconAlt alts) StgLet b e -> StgLet (deconBinding b) (deconExpr e) StgLetNoEscape b e -> StgLetNoEscape (deconBinding b) (deconExpr e) StgTick t e -> StgTick t (deconExpr e) @@ -98,7 +106,7 @@ deconAltType = \case AlgAlt tcOcc -> AlgAlt (deconTcOcc tcOcc) deconAlt :: Alt -> SAlt -deconAlt Alt{..} = Alt (deconAltCon altCon) (map deconIdBnd altBinders) (deconExpr altRHS) +deconAlt Alt{..} = Alt (deconAltCon altCon) (fmap deconIdBnd altBinders) (deconExpr altRHS) deconAltCon :: AltCon -> SAltCon deconAltCon = \case @@ -109,7 +117,7 @@ deconAltCon = \case deconForeignStubs :: ForeignStubs -> SForeignStubs deconForeignStubs = \case NoStubs -> NoStubs - ForeignStubs h c i f l -> ForeignStubs h c i f $ map deconStubDecl l + ForeignStubs h c i f l -> ForeignStubs h c i f $ fmap deconStubDecl l deconStubDecl :: StubDecl -> SStubDecl deconStubDecl = \case diff --git a/external-stg/lib/Stg/Foreign/Linker.hs b/external-stg/lib/Stg/Foreign/Linker.hs index 172f952..eaad660 100644 --- a/external-stg/lib/Stg/Foreign/Linker.hs +++ b/external-stg/lib/Stg/Foreign/Linker.hs @@ -1,15 +1,24 @@ -{-# LANGUAGE RecordWildCards #-} module Stg.Foreign.Linker where -import Data.List -import System.Directory -import System.FilePath -import System.Process -import Text.Printf +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..)) -import Stg.Program -import Stg.Syntax -import Stg.Foreign.Stubs +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor (Functor(..)) +import Data.List (concat, concatMap, filter, intercalate, unlines, unwords, (++)) + +import Stg.Foreign.Stubs (genStubs) +import Stg.Program (StgAppLinkerInfo (..), StgLibLinkerInfo (..), getAppLinkerInfo) + +import System.Directory (createDirectoryIfMissing, makeAbsolute) +import System.FilePath (FilePath, takeBaseName, takeDirectory, ()) +import System.IO (IO, writeFile) +import System.Process (callCommand) + +import Text.Printf (printf) +import Text.Show (Show (..)) getExtStgWorkDirectory :: FilePath -> IO FilePath getExtStgWorkDirectory ghcstgappFname = do @@ -66,10 +75,10 @@ linkForeignCbitsSharedLib ghcstgappFname = do [ "#!/usr/bin/env bash" , "set -e" , case stgappPlatformOS of - "darwin" -> "gcc -o cbits.so -shared \\" - _ -> "gcc -o cbits.so -shared -Wl,--no-as-needed \\" + "darwin" -> "gcc -o cbits.so -shared \\" + _ -> "gcc -o cbits.so -shared -Wl,--no-as-needed \\" ] ++ - intercalate " \\\n" (map (" " ++) . filter (/= "") $ arList ++ cbitsOpts ++ stgappCObjects ++ [appOpts] ++ stubOpts) ++ "\n" + intercalate " \\\n" (fmap (" " ++) . filter (/= "") $ arList ++ cbitsOpts ++ stgappCObjects ++ [appOpts] ++ stubOpts) ++ "\n" let scriptFname = workDir "cbits.so.sh" writeFile scriptFname linkScript diff --git a/external-stg/lib/Stg/Foreign/Stubs.hs b/external-stg/lib/Stg/Foreign/Stubs.hs index 3641560..bbebf61 100644 --- a/external-stg/lib/Stg/Foreign/Stubs.hs +++ b/external-stg/lib/Stg/Foreign/Stubs.hs @@ -1,16 +1,27 @@ -{-# LANGUAGE LambdaCase #-} module Stg.Foreign.Stubs where +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..)) + +import Data.Bool (Bool (..), not) import qualified Data.ByteString.Char8 as BS8 +import Data.Function (($), (.)) +import Data.List (concat, filter, null, (++)) +import Data.String (String, unlines) + +import Stg.GHC.Symbols (Symbol (..), rtsSymbols) +import Stg.Program (getGhcStgAppModules) +import Stg.Syntax (CExportSpec (..), ForeignExport (..), ForeignStubs' (..), Module' (..), + StubDecl, StubDecl' (StubDeclExport, StubDeclImport)) + +import System.IO (FilePath, IO) -import Stg.Program -import Stg.Syntax -import Stg.GHC.Symbols +import Text.Show (Show (..)) genStubs :: FilePath -> IO String genStubs ghcstgappFname = do mods <- getGhcStgAppModules ghcstgappFname - let stubs = concat $ [map genStubCode l | ForeignStubs _ _ _ _ l <- map moduleForeignStubs $ mods] + let stubs = concat $ [fmap genStubCode l | ForeignStubs _ _ _ _ l <- fmap moduleForeignStubs $ mods] fileIncludes = [ "#include " , "#include " -- , "#include \"HsFFI.h\"" diff --git a/external-stg/lib/Stg/Fullpak.hs b/external-stg/lib/Stg/Fullpak.hs index c39a9d2..a54e1ca 100644 --- a/external-stg/lib/Stg/Fullpak.hs +++ b/external-stg/lib/Stg/Fullpak.hs @@ -1,22 +1,33 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} -module Stg.Fullpak - ( mkFullpak - ) where - -import Control.Monad -import qualified Data.ByteString.Char8 as BS8 -import System.FilePath -import System.Directory -import Codec.Archive.Zip -import Codec.Archive.Zip.Unix -import Text.Printf - -import qualified Data.Map as Map -import qualified Data.Yaml as Y - -import Stg.Program -import Stg.Foreign.Linker -import qualified Stg.GHC.Symbols as GHCSymbols +module Stg.Fullpak (mkFullpak) where + +import Codec.Archive.Zip (CompressionMethod (..), ZipArchive, addEntry, copyEntry, createArchive, + doesEntryExist, loadEntry, mkEntrySelector, setExternalFileAttrs, + unEntrySelector, withArchive) +import Codec.Archive.Zip.Unix (fromFileMode) + +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..), Monad (..), filterM, forM, forM_, mapM) + +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (($)) +import Data.List (find, length, (++)) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import qualified Data.Yaml as Y + +import Stg.Foreign.Linker (getExtStgWorkDirectory, linkForeignCbitsSharedLib) +import qualified Stg.GHC.Symbols as GHCSymbols +import Stg.Program (AppInfo (..), CodeInfo (..), StgAppForeignSourceInfo (..), + StgAppLicenseInfo (..), StgModuleInfo (..), collectProgramModules, + getAppForeignFiles, getAppLicenseInfo, getAppModuleMapping) + +import System.Directory (doesFileExist) +import System.FilePath (FilePath, takeFileName, ()) +import System.IO (IO, putStrLn) + +import Text.Printf (printf) +import Text.Show (Show (..)) getModuleList :: [StgModuleInfo] -> IO [FilePath] getModuleList modinfoList = do @@ -35,9 +46,12 @@ mkFullpak :: FilePath -> Bool -> Bool -> FilePath -> IO () mkFullpak ghcstgappPath stgbinsOnly includeAll fullpakName = do -- mk .fullpak modinfoList <- getAppModuleMapping ghcstgappPath + + let mainUnitId = modUnitId $ fromJust $ find (\a -> modModuleName a == "Main") modinfoList + appModpaks <- if includeAll then getModuleList modinfoList - else collectProgramModules (map modModpakPath modinfoList) "main" "Main" GHCSymbols.liveSymbols + else collectProgramModules (fmap modModpakPath modinfoList) mainUnitId "Main" GHCSymbols.liveSymbols let modpakMap = Map.fromList [(modModpakPath m , m) | m <- modinfoList] fullpakModules = [modpakMap Map.! m | m <- appModpaks] diff --git a/external-stg/lib/Stg/GHC/Symbols.hs b/external-stg/lib/Stg/GHC/Symbols.hs index a68a501..09a7756 100644 --- a/external-stg/lib/Stg/GHC/Symbols.hs +++ b/external-stg/lib/Stg/GHC/Symbols.hs @@ -1,6 +1,12 @@ module Stg.GHC.Symbols where -import Stg.Syntax +import Data.Eq (Eq) +import Data.List ((++)) +import Data.Ord (Ord) +import Data.String (String) + +import Text.Show (Show) + liveSymbols :: [(String, String, String)] liveSymbols = @@ -75,7 +81,7 @@ data Symbol | CData { getSymbolName :: String } | CmmFun { getSymbolName :: String } | CmmData { getSymbolName :: String } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) rtsSymbols :: [Symbol] rtsSymbols = @@ -94,6 +100,12 @@ rtsSymbols = , CFun "getRTSStatsEnabled" -- c fun , CFun "getRTSStats" -- c fun + -- Assume charset names are ASCII + , CFun "localeEncoding" -- c fun + + -- checks to see whether input is available on the file descriptor + , CFun "fdReady" -- c fun + -- used by haskell base library ; stack trace , CFun "backtraceFree" -- c fun , CFun "libdwGetBacktrace" -- c fun diff --git a/external-stg/lib/Stg/IO.hs b/external-stg/lib/Stg/IO.hs index 0adf4d3..867eac3 100644 --- a/external-stg/lib/Stg/IO.hs +++ b/external-stg/lib/Stg/IO.hs @@ -15,19 +15,22 @@ module Stg.IO , modpakStgbinPath ) where -import Prelude hiding (readFile) +import Codec.Archive.Zip (doesEntryExist, getEntry, mkEntrySelector, withArchive) -import Control.Monad.IO.Class -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 +import Control.Applicative ((<$>)) + +import Data.Binary (decode) +import Data.Bool (Bool) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import Data.Binary -import Data.Binary.Get -import Codec.Archive.Zip -import System.FilePath +import Data.Function (($), (.)) +import Data.Maybe (Maybe) +import Data.String (String) + +import Stg.Reconstruct (reconModule) +import Stg.Syntax (Module, ModuleName, Name, SForeignStubs, SModule, UnitId) -import Stg.Syntax -import Stg.Reconstruct +import System.IO (FilePath, IO) -- from .modpak file diff --git a/external-stg/lib/Stg/IRLocation.hs b/external-stg/lib/Stg/IRLocation.hs index 246e6ce..cadcbb2 100644 --- a/external-stg/lib/Stg/IRLocation.hs +++ b/external-stg/lib/Stg/IRLocation.hs @@ -1,16 +1,26 @@ -{-# LANGUAGE RecordWildCards #-} module Stg.IRLocation where -import Stg.Syntax +import Data.Eq (Eq) +import Data.Int (Int) +import Data.Maybe (Maybe (..)) +import Data.Ord (Ord) + +import GHC.Err (undefined) + +import Stg.Syntax (Alt, Arg, Binder (..), BinderId (..), Binding, Expr, Module, Name, Rhs, Scope (..), + TopBinding, Unique, getModuleName, getUnitId) + +import Text.Read (Read) +import Text.Show (Show) data StgId = StgId - { siUnitId :: Name - , siModuleName :: Name - , siName :: Name - , siUnique :: Maybe Unique + { siUnitId :: Name + , siModuleName :: Name + , siName :: Name + , siUnique :: Maybe Unique } - deriving (Eq, Ord, Show, Read) + deriving stock (Eq, Ord, Show, Read) binderToStgId :: Binder -> StgId binderToStgId Binder{..} = StgId @@ -33,7 +43,7 @@ data StgPoint | SP_RhsCon { spRhsBinderName :: StgId } | SP_Binding { spBinderName :: StgId } | SP_Tickish { spParent :: StgPoint } - deriving (Eq, Ord, Show, Read) + deriving stock (Eq, Ord, Show, Read) {- breakpoint types: @@ -114,7 +124,7 @@ data FieldSelector -- Alt | FS_Alt_altBinders Int -- selects: Alt -> Binder | FS_Alt_altRHS -- selects: Alt -> Expr - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) type IRPath = [FieldSelector] @@ -127,7 +137,7 @@ data IR | IR_Expr Expr | IR_Alt Alt | IR_Binder Binder - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) lookupIR :: IR -> IRPath -> IR lookupIR = undefined diff --git a/external-stg/lib/Stg/JSON.hs b/external-stg/lib/Stg/JSON.hs index 6c5f21c..16b4795 100644 --- a/external-stg/lib/Stg/JSON.hs +++ b/external-stg/lib/Stg/JSON.hs @@ -1,12 +1,24 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + module Stg.JSON where -import Data.Aeson -import Stg.Syntax +import Control.Monad (Functor (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value) import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Text.Lazy as Text +import Data.Function ((.)) +import qualified Data.Text.Lazy as Text + +import Stg.Syntax (Alt', AltCon', AltType', Arg', Binder, BinderId, Binding', BufSpan, CCallConv, + CCallTarget, CExportSpec, CImportSpec, CbvMark, DataConId, DataConRep, Expr', + ForeignCall, ForeignExport, ForeignImport, ForeignStubs', Header, IdDetails, + LabelSpec, Lit, LitNumType, Module', ModuleCLabel, ModuleLabelKind, ModuleName, + PrimCall, PrimElemRep, PrimRep, RealSrcSpan, Rhs', SBinder, SDataCon, STyCon, + Safety, Scope, SourceText, SrcSpan, StgOp, StubDecl', StubImpl, Tickish, + TopBinding', TyConId, Type, UnhelpfulSpanReason, Unique, UnitId, UpdateFlag) instance ToJSON BS8.ByteString where + toJSON :: BS8.ByteString -> Value toJSON = toJSON . Text.pack . BS8.unpack instance ToJSON Unique diff --git a/external-stg/lib/Stg/Pretty.hs b/external-stg/lib/Stg/Pretty.hs index 5b194fc..3b81ce1 100644 --- a/external-stg/lib/Stg/Pretty.hs +++ b/external-stg/lib/Stg/Pretty.hs @@ -1,44 +1,57 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards, LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Stg.Pretty where - -import Control.Monad -import Control.Applicative -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.Writer hiding (Alt) -import Control.Monad.State -import Control.Monad.RWS hiding (Alt) -import Data.Maybe -import Data.Foldable -import Data.String (IsString(..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO - -import Stg.Syntax -import Stg.IRLocation - -import Data.Ratio -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint.Final -import Text.PrettyPrint.Final.Words -import Text.PrettyPrint.Final.Extensions.Environment +import Control.Applicative (Alternative (..), Applicative (..), (<$>)) +import Control.Monad (Monad (..)) +import Control.Monad.Identity (Identity (..)) +import Control.Monad.Reader (MonadReader, ReaderT (ReaderT)) +import Control.Monad.RWS (RWST (..)) +import Control.Monad.State (MonadState, State, execState, gets, modify') +import Control.Monad.Writer (MonadWriter) + +import Data.Bool (Bool (..), otherwise) +import qualified Data.ByteString.Char8 as BS +import Data.Eq (Eq (..)) +import Data.Function (const, id, ($), (.)) +import Data.Functor (Functor (..)) +import Data.Int (Int) +import Data.List (concatMap, filter, repeat, replicate, reverse, zip, + (++)) +import Data.Maybe (Maybe (..), fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.Ord (Ord (..)) +import Data.Ratio (Rational, denominator, numerator) +import Data.Semigroup (Semigroup (..)) +import Data.String (IsString (..), String) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Tuple (fst) + +import GHC.Err (error) +import GHC.Num (Integer, Num (..)) + +import Prelude (Enum (..)) + +import Stg.IRLocation (StgPoint (..), binderToStgId) +import Stg.Syntax (Alt, Alt' (..), AltCon, AltCon' (..), AltType, + AltType' (..), Arg, Arg' (..), Binder (..), + BinderId (..), Binding, Binding' (..), CCallConv, + CCallTarget (..), DataCon (..), DataConRep (..), Expr, + Expr' (..), ForeignCall (..), ForeignStubs, + ForeignStubs' (..), Id (Id), Lit (..), LitNumType (..), + Module, Module' (..), ModuleName, Name, PrimCall (..), + PrimRep (VecRep), RealSrcSpan (..), Rhs, Rhs' (..), + Safety, Scope (..), StgOp (..), Tickish (..), + TopBinding, TopBinding' (..), TyCon (..), Type (..), + UnitId, getModuleName, getUnitId) + +import Text.PrettyPrint.Final (Atom (..), Chunk (..), Failure (..), Layout (..), Line, + Measure (..), MonadPretty, PEnv (..), POut (..), + PState (..), align, annotate, char, collection, grouped, + hsep, nest, newline, text, vsep) +import Text.PrettyPrint.Final.Extensions.Environment (EnvT (..), MonadPrettyEnv, MonadReaderEnv (..), runEnvT) +import Text.PrettyPrint.Final.Words (braces, comma, parens) +import Text.Show (Show (..)) --------------------------------------------------------- type SrcPos = (Int, Int) @@ -89,7 +102,7 @@ code Expr - code Rhs StgRhsClosure - none ; expr covers it - StgRhsCon - + StgRhsCon - -} {- @@ -102,9 +115,9 @@ code -} getStgPoint :: DocM StgPoint -getStgPoint = (speStgPoint <$> askEnv) >>= \case +getStgPoint = askEnv >>= (\case Nothing -> error "missing stg point" - Just sp -> pure sp + Just sp -> pure sp) . speStgPoint --------------------------------------------------------- env0 :: Monoid fmt => PEnv Int a fmt @@ -123,7 +136,7 @@ state0 = PState { curLine = [] } -data Config +newtype Config = Config { cfgPrintTickish :: Bool } @@ -146,8 +159,7 @@ spEnv0 cfg = SPEnv -- For plain text pretty printing newtype DocM a = DocM { unDocM :: EnvT SPEnv (RWST (PEnv Int StgPoint ()) (POut Int StgPoint) (PState Int ()) Maybe) a } - deriving - ( Functor, Applicative, Monad, Alternative + deriving newtype (Functor, Applicative, Monad, Alternative , MonadReader (PEnv Int StgPoint ()) , MonadWriter (POut Int StgPoint) , MonadState (PState Int ()) @@ -167,39 +179,48 @@ execDoc :: Config -> Doc -> POut Int StgPoint execDoc cfg d = let rM = runDocM env0 (spEnv0 cfg) state0 d in case rM of - Nothing -> PAtom $ AChunk $ CText "" + Nothing -> PAtom $ AChunk $ CText "" Just (_, o, ()) -> o type Doc = DocM () instance Semigroup Doc where + (<>) :: Doc -> Doc -> Doc (<>) = (>>) instance Monoid Doc where + mempty :: Doc mempty = return () class Pretty a where pretty :: a -> Doc instance Pretty Doc where + pretty :: Doc -> Doc pretty = id instance Pretty Int where + pretty :: Int -> Doc pretty = text . T.pack . show instance Pretty Integer where + pretty :: Integer -> Doc pretty = text . T.pack . show instance Measure Int () DocM where + measure :: Line Int () -> DocM Int measure = return . runIdentity . measure instance Pretty Text where + pretty :: Text -> Doc pretty = text . T.pack . show instance Pretty String where + pretty :: String -> Doc pretty = text . T.pack instance Pretty Name where + pretty :: Name -> Doc pretty = text . T.pack . BS.unpack --------------------------------------------------------- @@ -216,29 +237,35 @@ angles x = char '<' >> x >> char '>' (<+>) :: MonadPretty w ann fmt m => m a -> m b -> m b a <+> b = a >> char ' ' >> b +(<$$>) :: (MonadPretty w ann fmt m, Semigroup (m ())) => m () -> m () -> m () x <$$> y = x <> newline <> y +hang :: MonadPretty w ann fmt m => w -> m a -> m a hang i d = align (nest i d) + +indent :: Int -> DocM () -> DocM () indent i d = hang i (textS (spaces i) <> d) vcat :: [Doc] -> Doc vcat = vsep +sep :: [DocM ()] -> DocM () sep = grouped . vsep spaces :: Int -> String spaces n | n <= 0 = "" | otherwise = replicate n ' ' +textS :: String -> DocM () textS = text . T.pack -------------------------------------------------------- ppType :: Type -> Doc ppType t = red $ case t of - SingleValue r -> ppPrimRep r - UnboxedTuple l -> braces $ hsep (map ppPrimRep l) - PolymorphicRep -> text "PolymorphicRep" + SingleValue r -> ppPrimRep r + UnboxedTuple l -> braces $ hsep (fmap ppPrimRep l) + PolymorphicRep -> text "PolymorphicRep" ppPrimRep :: PrimRep -> Doc ppPrimRep = \case @@ -247,15 +274,15 @@ ppPrimRep = \case colorBinderExport :: Binder -> Doc -> Doc colorBinderExport b = case binderScope b of - ClosurePrivate -> id - ModulePrivate -> id - ModulePublic -> green + ClosurePrivate -> id + ModulePrivate -> id + ModulePublic -> green pprBinderTypeSig :: Binder -> Doc pprBinderTypeSig b = pprVar b <+> text "::" <+> ppType (binderType b) pprBinder :: Binder -> Doc -pprBinder b = pprVar b +pprBinder = pprVar {- name handling design: @@ -275,18 +302,22 @@ pprVar b@Binder{..} BinderId u = binderId instance Pretty Type where + pretty :: Type -> Doc pretty = ppType instance Pretty UnitId where + pretty :: UnitId -> Doc pretty = text . T.pack . BS.unpack . getUnitId instance Pretty ModuleName where + pretty :: ModuleName -> Doc pretty = text . T.pack . BS.unpack . getModuleName pprRational :: Rational -> Doc pprRational r = pretty (numerator r) <> "/" <> pretty (denominator r) instance Pretty LitNumType where + pretty :: LitNumType -> Doc pretty = \case LitNumInt -> "Int" LitNumInt8 -> "Int8" @@ -300,21 +331,24 @@ instance Pretty LitNumType where LitNumWord64 -> "Word64" instance Pretty Lit where - pretty (LitChar x) = text (T.pack $ show x) - pretty (LitString x) = text (T.pack $ show x) - pretty LitNullAddr = "nullAddr#" - pretty (LitFloat x) = (pprRational x) - pretty (LitDouble x) = (pprRational x) - pretty (LitLabel x s) = text "LABEL" <+> parens (pretty x) <+> textS (show s) - pretty (LitNumber t i) = pretty i - pretty (LitRubbish t) = text "#Rubbish" <+> pretty t + pretty :: Lit -> Doc + pretty (LitChar x) = text (T.pack $ show x) + pretty (LitString x) = text (T.pack $ show x) + pretty LitNullAddr = "nullAddr#" + pretty (LitFloat x) = pprRational x + pretty (LitDouble x) = pprRational x + pretty (LitLabel x s) = text "LABEL" <+> parens (pretty x) <+> textS (show s) + pretty (LitNumber _t i) = pretty i + pretty (LitRubbish t) = text "#Rubbish" <+> pretty t instance Pretty AltCon where + pretty :: AltCon -> Doc pretty (AltDataCon dc) = pprDataConName dc - pretty (AltLit l) = pretty l - pretty AltDefault = text "_" + pretty (AltLit l) = pretty l + pretty AltDefault = text "_" instance Pretty AltType where + pretty :: AltType -> Doc pretty = \case PolyAlt -> text "PolyAlt" MultiValAlt i -> text "MultiValAlt" <+> pretty i @@ -323,7 +357,7 @@ instance Pretty AltType where pprAlt :: Id -> Int -> Alt -> Doc pprAlt (Id scrutBinder) idx (Alt con bndrs rhs) = - (hsep (pretty con : map (pprBinder) bndrs) <+> text "-> do") <$$> + (hsep (pretty con : fmap pprBinder bndrs) <+> text "-> do") <$$> indent 2 (withStgPoint (SP_AltExpr (binderToStgId scrutBinder) idx) $ pprExpr rhs) pprArg :: Arg -> Doc @@ -332,27 +366,32 @@ pprArg = \case StgLitArg l -> pretty l instance Pretty Safety where + pretty :: Safety -> Doc pretty = textS . show instance Pretty CCallConv where + pretty :: CCallConv -> Doc pretty = textS . show instance Pretty CCallTarget where + pretty :: CCallTarget -> Doc pretty = textS . show instance Pretty ForeignCall where + pretty :: ForeignCall -> Doc pretty ForeignCall{..} = braces $ hsep [pretty foreignCSafety, pretty foreignCConv, pretty foreignCTarget] instance Pretty PrimCall where + pretty :: PrimCall -> Doc pretty (PrimCall lbl uid) = braces $ hsep [pretty uid, pretty lbl] pprOp :: StgOp -> Doc pprOp = \case StgPrimOp op -> text "primop" <+> pretty (show op) - StgPrimCallOp (PrimCall sym uid) -> text "cmmcall" <+> pretty (show sym)-- <+> text "-- from package:" <+> pretty uid + StgPrimCallOp (PrimCall sym _uid) -> text "cmmcall" <+> pretty (show sym)-- <+> text "-- from package:" <+> pretty uid StgFCallOp ForeignCall{..} -> case foreignCTarget of StaticTarget _ sym _ _ -> text "foreigncall" <+> pretty (show sym) - DynamicTarget -> text "foreigncall dynamic_call_target" + DynamicTarget -> text "foreigncall dynamic_call_target" {- - put infix names to parenthesis @@ -384,13 +423,14 @@ pprOp = \case putDefaultLast :: [Alt] -> [Doc] -> [Doc] putDefaultLast (Alt AltDefault _ _ : _) (first : rest) = rest ++ [first] -putDefaultLast _ l = l +putDefaultLast _ l = l pprRealSrcSpan :: RealSrcSpan -> Doc pprRealSrcSpan RealSrcSpan'{..} = pretty srcSpanFile <+> pprPos srcSpanSLine srcSpanSCol <> text "-" <> pprPos srcSpanELine srcSpanECol where pprPos line col = parens $ pretty line <> text ":" <> pretty col instance Pretty RealSrcSpan where + pretty :: RealSrcSpan -> Doc pretty = pprRealSrcSpan pprTickish :: Tickish -> Doc @@ -401,6 +441,7 @@ pprTickish = \case SourceNote{..} -> text "-- SourceNote for" <+> pretty sourceName <+> pretty sourceSpan instance Pretty Tickish where + pretty :: Tickish -> Doc pretty = pprTickish pprExpr :: Expr -> Doc @@ -408,31 +449,31 @@ pprExpr exp = do stgPoint <- getStgPoint annotate stgPoint $ case exp of StgLit l -> pretty l - StgCase x b at [Alt AltDefault [] rhs] -> sep + StgCase x b _at [Alt AltDefault [] rhs] -> sep [ withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $ pprBinder b <+> text "<-" <+> nest 2 (pprExpr x) , withStgPoint (SP_AltExpr (binderToStgId b) 0) $ pprExpr rhs ] - StgCase x b at [Alt con bndrs rhs] -> sep + StgCase x b _at [Alt con bndrs rhs] -> sep [ withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $ - pprBinder b <+> text "@" <+> parens (hsep $ pretty con : map (pprBinder) bndrs) <+> text "<-" <+> nest 2 (pprExpr x) + pprBinder b <+> text "@" <+> parens (hsep $ pretty con : fmap pprBinder bndrs) <+> text "<-" <+> nest 2 (pprExpr x) , withStgPoint (SP_AltExpr (binderToStgId b) 0) $ pprExpr rhs ] - StgCase x b at alts -> sep + StgCase x b _at alts -> sep [ withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $ pprBinder b <+> text "<-" <+> nest 2 (pprExpr x) , text "case" <+> pprVar b <+> text "of" , indent 2 $ vcat $ putDefaultLast alts [pprAlt (Id b) idx a | (idx, a) <- zip [0..] alts] ] - StgApp f args -> (pprVar f) <+> (hsep $ map (pprArg) args) - StgOpApp op args ty n -> (pprOp op) <+> (hsep $ map (pprArg) args){- <+> text "::" <+> (pretty ty) <+> maybe mempty (parens . ppTyConName) n -} - StgConApp dc args _t -> addUnboxedCommentIfNecessary dc $ (pprDataConName dc) <+> (hsep $ map (pprArg) args) - StgLet b e -> text "let" <+> (align $ pprBinding b) <$$> align (withStgPoint (SP_LetExpr stgPoint) $ pprExpr e) + StgApp f args -> pprVar f <+> hsep (fmap pprArg args) + StgOpApp op args _ty _n -> pprOp op <+> hsep (fmap pprArg args){- <+> text "::" <+> (pretty ty) <+> maybe mempty (parens . ppTyConName) n -} + StgConApp dc args _t -> addUnboxedCommentIfNecessary dc $ pprDataConName dc <+> hsep (fmap pprArg args) + StgLet b e -> text "let" <+> align (pprBinding b) <$$> align (withStgPoint (SP_LetExpr stgPoint) $ pprExpr e) StgLetNoEscape b e -> vsep [ text "-- stack allocating let" - , text "let" <+> (align $ pprBinding b) <$$> align (withStgPoint (SP_LetNoEscapeExpr stgPoint) $ pprExpr e) + , text "let" <+> align (pprBinding b) <$$> align (withStgPoint (SP_LetNoEscapeExpr stgPoint) $ pprExpr e) ] StgTick tickish e -> do Config{..} <- speConfig <$> askEnv @@ -441,12 +482,13 @@ pprExpr exp = do else pprExpr e instance Pretty Expr where + pretty :: Expr -> Doc pretty = pprExpr addUnboxedCommentIfNecessary :: DataCon -> Doc -> Doc addUnboxedCommentIfNecessary DataCon{..} doc = case dcRep of UnboxedTupleCon{} -> doc -- vsep [text "-- stack allocated unboxed tuple", doc] - _ -> doc + _ -> doc {- pprSrcSpan :: SrcSpan -> Doc pprSrcSpan = \case @@ -457,24 +499,30 @@ pprSrcSpan = \case -} pprRhs :: Id -> Rhs -> Doc pprRhs (Id rhsBinder) = \case - StgRhsClosure _ u bs e -> annotate (SP_Binding $ binderToStgId rhsBinder) $ do - pprBinder rhsBinder <+> hsep (map pprBinder bs) <+> text "= do" <> (newline <> (indent 2 $ withStgPoint (SP_RhsClosureExpr $ binderToStgId rhsBinder) $ pprExpr e)) - StgRhsCon dc vs -> annotate (SP_RhsCon $ binderToStgId rhsBinder) $ do - pprBinder rhsBinder <+> text "=" <+> addUnboxedCommentIfNecessary dc (pprDataConName dc <+> (hsep $ map (pprArg) vs)) + StgRhsClosure _ _ bs e -> + annotate (SP_Binding $ binderToStgId rhsBinder) $ + pprBinder rhsBinder <+> hsep (fmap pprBinder bs) <+> text "= do" + <> newline + <> indent 2 (withStgPoint (SP_RhsClosureExpr $ binderToStgId rhsBinder) $ pprExpr e) + StgRhsCon dc vs -> + annotate (SP_RhsCon $ binderToStgId rhsBinder) $ + pprBinder rhsBinder + <+> text "=" + <+> addUnboxedCommentIfNecessary dc (pprDataConName dc <+> hsep (fmap pprArg vs)) pprBinding :: Binding -> Doc pprBinding = \case StgNonRec b r -> pprBind (b,r) - StgRec bs -> vsep (map pprBind bs) + StgRec bs -> vsep (fmap pprBind bs) where pprBind (b,rhs) = - (pprRhs (Id b) rhs) + pprRhs (Id b) rhs pprTopBinding :: TopBinding -> Doc pprTopBinding = \case StgTopLifted (StgNonRec b r) -> pprTopBind (b,r) - StgTopLifted (StgRec bs) -> vsep (map pprTopBind bs) - StgTopStringLit b s -> pprTopBind' (\(Id b) str -> pprBinder b <+> text "=" <+> (textS . show $ str)) (b,s) + StgTopLifted (StgRec bs) -> vsep (fmap pprTopBind bs) + StgTopStringLit b s -> pprTopBind' (\(Id b') str -> pprBinder b' <+> text "=" <+> (textS . show $ str)) (b,s) where pprTopBind = pprTopBind' pprRhs pprTopBind' f (b, rhs) = sep @@ -482,8 +530,8 @@ pprTopBinding = \case , f (Id b) rhs , mempty ] - instance Pretty TopBinding where + pretty :: TopBinding -> Doc pretty = pprTopBinding ppTyConName :: TyCon -> Doc @@ -491,12 +539,12 @@ ppTyConName TyCon{..} = {-pretty tcUnitId <> text "_" <> pretty tcModule <> text pprTyCon :: TyCon -> Doc pprTyCon TyCon{..} = {-pretty tcUnitId <> text "_" <> pretty tcModule <> text "." <> -} - text "data" <+> pretty tcName <$$> (indent 2 $ vsep ([text c <+> pprDataConDef dc | (dc, c) <- zip tcDataCons ("=" : repeat "|")])) + text "data" <+> pretty tcName <$$> indent 2 (vsep ([text c <+> pprDataConDef dc | (dc, c) <- zip tcDataCons ("=" : repeat "|")])) pprDataConDef :: DataCon -> Doc pprDataConDef DataCon{..} = case dcRep of - AlgDataCon dcArgsRep -> pretty dcName <+> hsep (map ppPrimRep dcArgsRep) - x -> textS $ "-- " ++ show x + AlgDataCon dcArgsRep -> pretty dcName <+> hsep (fmap ppPrimRep dcArgsRep) + x -> textS $ "-- " ++ show x pprDataConName :: DataCon -> Doc pprDataConName DataCon{..} = {-pretty dcUnitId <> text "_" <> pretty dcModule <> text "." <> -}pretty dcName{- <+> text "::" <+> textS (show dcRep) <+> parens (textS (show dcId))-} @@ -523,11 +571,11 @@ pprModule Module{..} = vsep , modName == moduleName , tc <- tl ] - , vsep (map (pprTopBinding) moduleTopBindings) + , vsep (fmap pprTopBinding moduleTopBindings) ] pprImportList :: UnitId -> ModuleName -> [Binder] -> Doc -pprImportList u mod bl = text "import" <+> text "\"" <> pretty u <> text "\"" <+> pretty mod <+> align (collection "(" ")" "," $ map pprVar bl) +pprImportList u mod bl = text "import" <+> text "\"" <> pretty u <> text "\"" <+> pretty mod <+> align (collection "(" ")" "," $ fmap pprVar bl) pprExportList :: [TopBinding] -> Doc pprExportList l = vsep @@ -538,14 +586,15 @@ pprExportList l = vsep exportedBinders = filter ((ModulePublic ==) . binderScope) $ getTopBinders l getTopBinders :: [TopBinding] -> [Binder] -getTopBinders topBindings = concatMap go topBindings +getTopBinders = concatMap go where go = \case StgTopStringLit b _ -> [b] StgTopLifted (StgNonRec b _) -> [b] - StgTopLifted (StgRec l) -> map fst l + StgTopLifted (StgRec l) -> fmap fst l instance Pretty Module where + pretty :: Module -> Doc pretty = pprModule pprForeignStubs :: ForeignStubs -> Doc @@ -554,7 +603,7 @@ pprForeignStubs = \case ForeignStubs{..} -> vsep [ text "foreign stub C header {" <$$> green (pretty fsCHeader) <$$> text "}" , text "foreign stub C source {" <$$> green (pretty fsCSource) <$$> text "}" - , text "foreign decls {" <$$> (indent 2 $ vsep $ map (textS . show) fsDecls) <$$> text "}" + , text "foreign decls {" <$$> indent 2 (vsep $ fmap (textS . show) fsDecls) <$$> text "}" ] comment :: Doc -> Doc @@ -565,10 +614,10 @@ comment x = text "{-" <+> x <+> text "-}" data StgPointState = StgPointState - { spsRow :: Int - , spsCol :: Int - , spsStgPoints :: [(StgPoint, SrcRange)] - , spsOutput :: [Text] + { spsRow :: Int + , spsCol :: Int + , spsStgPoints :: [(StgPoint, SrcRange)] + , spsOutput :: [Text] } emptyStgPointState :: StgPointState emptyStgPointState = StgPointState @@ -598,7 +647,7 @@ addStgPoint :: StgPoint -> SrcRange -> M () addStgPoint p r = modify' $ \s@StgPointState{..} -> s { spsStgPoints = (p, r) : spsStgPoints } getPos :: M SrcPos -getPos = (,) <$> gets spsRow <*> gets spsCol +getPos = gets ((,) . spsRow) <*> gets spsCol pShow :: Doc -> (Text, [(StgPoint, SrcRange)]) pShow = pShowWithConfig Config {cfgPrintTickish = False} diff --git a/external-stg/lib/Stg/Program.hs b/external-stg/lib/Stg/Program.hs index d7cc3d0..4fc52a5 100644 --- a/external-stg/lib/Stg/Program.hs +++ b/external-stg/lib/Stg/Program.hs @@ -1,73 +1,93 @@ -{-# LANGUAGE TupleSections, LambdaCase, RecordWildCards, OverloadedStrings #-} module Stg.Program where -import Control.Monad.IO.Class -import Control.Monad -import Text.Printf - -import Data.Maybe -import Data.List (isPrefixOf, groupBy, sortBy, foldl') -import Data.Containers.ListUtils (nubOrd) - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Aeson as Aeson - -import System.Process -import System.Directory -import System.FilePath -import System.FilePath.Find -import Codec.Archive.Zip - -import qualified Data.Yaml as Y -import Data.Yaml (ToJSON(..), FromJSON(..), (.:), (.:?), (.!=), (.=), object) - -import Stg.Syntax -import Stg.IO -import Stg.JSON () -import Stg.Reconstruct (reconModule) -import qualified Stg.GHC.Symbols as GHCSymbols +import Codec.Archive.Zip (getEntry, mkEntrySelector, withArchive) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.Monad (Functor (..), Monad (..), MonadFail (..), filterM, forM, forM_, unless, + when) +import Control.Monad.IO.Class (MonadIO (..)) + +import qualified Data.Aeson as Aeson +import Data.Bool (Bool (..), not, otherwise, (&&)) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import Data.Containers.ListUtils (nubOrd) +import Data.Either (Either (..)) +import Data.Eq (Eq ((==))) +import Data.Function (($), (.)) +import Data.List (concat, drop, dropWhile, foldl, foldl', isPrefixOf, length, takeWhile, + unlines, unzip, zip, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), catMaybes, listToMaybe, maybeToList) +import Data.Monoid (Monoid (..)) +import Data.Ord (Ord) +import qualified Data.Set as Set +import Data.String (IsString (..), String) +import Data.Text (Text, replace, unpack) +import Data.Tuple (fst) +import Data.Yaml (FromJSON (..), ToJSON (..), object, (.!=), (.:), (.:?), (.=)) +import qualified Data.Yaml as Y + +import GHC.Err (error, undefined) + +import qualified Stg.GHC.Symbols as GHCSymbols +import Stg.IO (decodeStgbin, decodeStgbinInfo, fullpakAppInfoPath, modpakStgbinPath, + readModpakL) +import Stg.JSON () +import Stg.Reconstruct (reconModule) +import Stg.Syntax (Module, ModuleName (..), UnitId (..)) + +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, + getHomeDirectory) +import System.FilePath (FilePath, makeRelative, splitFileName, (-<.>), (<.>), ()) +import System.FilePath.Find (FileType (..), FilterPredicate, RecursionPredicate, always, extension, + fileType, find, (==?)) +import System.IO (IO, putStrLn) +import System.Process (callCommand) + +import Text.Printf (printf) +import Text.Read (read) +import Text.Show (Show (..)) moduleToModpak :: String -> String -> FilePath moduleToModpak modpakExt moduleName = replaceEq '.' '/' moduleName ++ modpakExt where replaceEq :: Eq a => a -> a -> [a] -> [a] - replaceEq from to = map (\cur -> if cur == from then to else cur) + replaceEq from to = fmap (\cur -> if cur == from then to else cur) parseSection :: [String] -> String -> [String] -parseSection content n = map (read . tail) . takeWhile (isPrefixOf "-") . tail . dropWhile (not . isPrefixOf n) $ content +parseSection content n = fmap (read . drop 1) . takeWhile (isPrefixOf "-") . drop 1 . dropWhile (not . isPrefixOf n) $ content printSection :: Show a => [a] -> String -printSection l = unlines ["- " ++ x | x <- nubOrd $ map show l] +printSection l = unlines ["- " ++ x | x <- nubOrd $ fmap show l] data StgModuleInfo = StgModuleInfo - { modModuleName :: String - , modModpakPath :: FilePath - , modPackageName :: String - , modPackageVersion :: String - , modUnitId :: String + { modModuleName :: String + , modModpakPath :: FilePath + , modPackageName :: String + , modPackageVersion :: String + , modUnitId :: String } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) data UnitLinkerInfo = UnitLinkerInfo - { unitName :: String - , unitVersion :: String - , unitId :: String - , unitImportDirs :: [FilePath] - , unitLibraries :: [String] - , unitLibDirs :: [FilePath] - , unitExtraLibs :: [String] - , unitLdOptions :: [String] - , unitExposedModules :: [String] - , unitHiddenModules :: [String] - , unitArtifactsDir :: Maybe FilePath - } deriving (Eq, Show) + { unitName :: String + , unitVersion :: String + , unitId :: String + , unitImportDirs :: [FilePath] + , unitLibraries :: [String] + , unitLibDirs :: [FilePath] + , unitExtraLibs :: [String] + , unitLdOptions :: [String] + , unitExposedModules :: [String] + , unitHiddenModules :: [String] + , unitArtifactsDir :: Maybe FilePath + } deriving stock (Eq, Show) instance FromJSON UnitLinkerInfo where + parseJSON :: Y.Value -> Y.Parser UnitLinkerInfo parseJSON (Y.Object v) = UnitLinkerInfo <$> v .: "name" @@ -103,9 +123,10 @@ data GhcStgApp , appExtraLibDirs :: [FilePath] , appLdOptions :: [String] , appLibDeps :: [UnitLinkerInfo] - } deriving (Eq, Show) + } deriving stock (Eq, Show) instance FromJSON GhcStgApp where + parseJSON :: Y.Value -> Y.Parser GhcStgApp parseJSON (Y.Object v) = GhcStgApp <$> v .:? "ways" .!= [] @@ -132,26 +153,25 @@ wpcModpaksPath, wpcCbitsPath, wpcCapiStubsPath, wpcCbitsSourcePath :: String wpcModpaksPath = "extra-compilation-artifacts" "wpc-plugin" "modpaks" wpcCbitsPath = "extra-compilation-artifacts" "wpc-plugin" "cbits" wpcCapiStubsPath = "extra-compilation-artifacts" "wpc-plugin" "capi-stubs" -wpcWrapperStubsPath = "extra-compilation-artifacts" "wpc-plugin" "wrapper-stubs" +-- wpcWrapperStubsPath = "extra-compilation-artifacts" "wpc-plugin" "wrapper-stubs" wpcCbitsSourcePath = "extra-compilation-artifacts" "wpc-plugin" "cbits-source" getAppModuleMapping :: FilePath -> IO [StgModuleInfo] getAppModuleMapping ghcStgAppFname = do let showLog = False -- TODO: use RIO ??? - let packageName = "exe:" ++ takeBaseName ghcStgAppFname -- TODO: save package to .ghc_stgapp + -- let packageName = "exe:" ++ takeBaseName ghcStgAppFname -- TODO: save package to .ghc_stgapp GhcStgApp{..} <- readGhcStgApp ghcStgAppFname let modpakExt = "." ++ appObjSuffix ++ "_modpak" check f = do --putStrLn $ "check: " ++ f exist <- doesFileExist f - unless exist $ when showLog $ do - putStrLn $ "modpak does not exist: " ++ f + unless exist $ when showLog $ putStrLn $ "modpak does not exist: " ++ f pure exist libModules <- filterM (check . modModpakPath) $ [ StgModuleInfo { modModuleName = mod - , modModpakPath = dir wpcModpaksPath moduleToModpak modpakExt mod + , modModpakPath = newDir wpcModpaksPath moduleToModpak modpakExt mod , modPackageName = unitName , modPackageVersion = unitVersion , modUnitId = unitId @@ -163,6 +183,7 @@ getAppModuleMapping ghcStgAppFname = do -- TODO: make this better somehow -- HINT: this module does not exist, it's a GHC builtin for primops , let builtin = mod == "GHC.Prim" && unitName == "ghc-prim" + newDir = unpack $ replace "bindist" "foundation-pak" $ fromString @Text dir , not builtin ] @@ -183,33 +204,41 @@ getAppModuleMapping ghcStgAppFname = do pure $ appMods ++ libModules getAppModpaks :: FilePath -> IO [FilePath] -getAppModpaks ghcStgAppFname = map modModpakPath <$> getAppModuleMapping ghcStgAppFname +getAppModpaks ghcStgAppFname = fmap modModpakPath <$> getAppModuleMapping ghcStgAppFname collectProgramModules' :: Bool -> [FilePath] -> String -> String -> [(String, String, String)] -> IO [FilePath] collectProgramModules' showLog modpakFileNames unitId mod liveSymbols = do -- filter dependenies only (fexportedList, depList) <- fmap unzip . forM modpakFileNames $ \fname -> do - (_, u, m, _, _, hasForeignExport, deps) <- readModpakL fname modpakStgbinPath decodeStgbinInfo - let fexport = if hasForeignExport then Just (u, m) else Nothing - pure (fexport, ((u, m), [(du, dm) | (du, dl) <- deps, dm <- dl])) - let fnameMap = Map.fromList $ zip (map fst depList) modpakFileNames - mnameMap = Map.fromList $ zip modpakFileNames (map fst depList) + (_, unitId', module', _, _, hasForeignExport, deps) <- readModpakL fname modpakStgbinPath decodeStgbinInfo + let fexport = if hasForeignExport then Just (unitId', module') else Nothing + pure + ( fexport, + ( (unitId', module'), + [(depUnitId, depModule) + | (depUnitId, depModuleNames) <- deps + , depModule <- depModuleNames + ] + ) + ) + let fnameMap = Map.fromList $ zip (fmap fst depList) modpakFileNames + mnameMap = Map.fromList $ zip modpakFileNames (fmap fst depList) depMap = Map.fromList depList calcDep s n | Set.member n s = s | Just l <- Map.lookup n depMap = foldl' calcDep (Set.insert n s) l - | otherwise = Set.insert n s -- error $ printf "missing module: %s" . show $ getModuleName n + | otherwise = Set.insert n s -- error $ printf "missing module: %s" . show $ snd n keyMain = (UnitId $ BS8.pack unitId, ModuleName $ BS8.pack mod) - prunedDeps = catMaybes [Map.lookup m fnameMap | m <- Set.toList $ foldl calcDep mempty $ keyMain : rtsDeps ++ catMaybes fexportedList] rtsDeps = [(UnitId $ BS8.pack u, ModuleName $ BS8.pack m) | (u, m, _) <- liveSymbols] + prunedDeps = catMaybes [Map.lookup m fnameMap | m <- Set.toList $ foldl calcDep mempty $ keyMain : rtsDeps ++ catMaybes fexportedList] + when showLog $ do putStrLn $ "all modules: " ++ show (length modpakFileNames) putStrLn $ "app modules: " ++ show (length prunedDeps) - putStrLn $ "app dependencies:\n" - forM_ [mnameMap Map.! fname | fname <- prunedDeps] $ \(UnitId uid, ModuleName mod) -> do - printf "%-60s %s\n" (BS8.unpack uid) (BS8.unpack mod) + putStrLn "app dependencies:\n" + forM_ [mnameMap Map.! fname | fname <- prunedDeps] $ \(UnitId uid, ModuleName mod') -> printf "%-60s %s\n" (BS8.unpack uid) (BS8.unpack mod') pure prunedDeps collectProgramModules :: [FilePath] -> String -> String -> [(String, String, String)] -> IO [FilePath] @@ -217,51 +246,49 @@ collectProgramModules = collectProgramModules' True -- .fullpak getFullpakModules :: FilePath -> IO [Module] -getFullpakModules fullpakPath = do - withArchive fullpakPath $ do - appinfoSelector <- liftIO $ mkEntrySelector fullpakAppInfoPath - AppInfo{..} <- getEntry appinfoSelector >>= Y.decodeThrow - forM aiLiveCode $ \CodeInfo{..} -> do - s <- liftIO $ mkEntrySelector $ "haskell" ciPackageName ciModuleName modpakStgbinPath - decodeStgbin . BSL.fromStrict <$> getEntry s +getFullpakModules fullpakPath = withArchive fullpakPath $ do + appinfoSelector <- liftIO $ mkEntrySelector fullpakAppInfoPath + AppInfo{..} <- getEntry appinfoSelector >>= Y.decodeThrow + forM aiLiveCode $ \CodeInfo{..} -> do + s <- liftIO $ mkEntrySelector $ "haskell" ciPackageName ciModuleName modpakStgbinPath + decodeStgbin . BSL.fromStrict <$> getEntry s -- .ghc_stgapp getGhcStgAppModules :: FilePath -> IO [Module] getGhcStgAppModules ghcstgappPath = do modinfoList <- getAppModuleMapping ghcstgappPath - appModpaks <- collectProgramModules' False (map modModpakPath modinfoList) "main" "Main" GHCSymbols.liveSymbols - forM appModpaks $ \modpakName -> do - readModpakL modpakName modpakStgbinPath decodeStgbin + appModpaks <- collectProgramModules' False (fmap modModpakPath modinfoList) "main" "Main" GHCSymbols.liveSymbols + forM appModpaks $ \modpakName -> readModpakL modpakName modpakStgbinPath decodeStgbin -- .json getJSONModules :: FilePath -> IO [Module] -getJSONModules filePath = do - res <- Aeson.eitherDecodeFileStrict' filePath +getJSONModules path = do + res <- Aeson.eitherDecodeFileStrict' path case res of Left err -> error err Right smodule -> pure [reconModule smodule] data StgLibLinkerInfo = StgLibLinkerInfo - { stglibName :: String - , stglibCbitsPaths :: [FilePath] - , stglibCapiStubsPaths :: [FilePath] - , stglibExtraLibs :: [String] - , stglibExtraLibDirs :: [FilePath] - , stglibLdOptions :: [String] + { stglibName :: String + , stglibCbitsPaths :: [FilePath] + , stglibCapiStubsPaths :: [FilePath] + , stglibExtraLibs :: [String] + , stglibExtraLibDirs :: [FilePath] + , stglibLdOptions :: [String] } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) data StgAppLinkerInfo = StgAppLinkerInfo - { stgappCObjects :: [FilePath] - , stgappExtraLibs :: [String] - , stgappExtraLibDirs :: [FilePath] - , stgappLdOptions :: [String] - , stgappPlatformOS :: String - , stgappNoHsMain :: Bool + { stgappCObjects :: [FilePath] + , stgappExtraLibs :: [String] + , stgappExtraLibDirs :: [FilePath] + , stgappLdOptions :: [String] + , stgappPlatformOS :: String + , stgappNoHsMain :: Bool } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) findIfExists :: RecursionPredicate -> FilterPredicate -> FilePath -> IO [FilePath] findIfExists rp fp path = do @@ -288,7 +315,7 @@ getAppLinkerInfo ghcStgAppFname = do } -- lib info - let forceDynamic = True + -- let forceDynamic = True {- arExt n = if forceDynamic then "-" ++ appGhcName ++ appGhcVersion ++ ".dyn_o" ++ n ++ ".a" @@ -296,11 +323,9 @@ getAppLinkerInfo ghcStgAppFname = do -} libInfoList <- forM appLibDeps $ \UnitLinkerInfo{..} -> do - cbitsPathList <- forM (maybeToList unitArtifactsDir) $ \path -> do - findIfExists always (extension ==? ".dyn_o") $ path wpcCbitsPath + cbitsPathList <- forM (maybeToList unitArtifactsDir) $ \path -> findIfExists always (extension ==? ".dyn_o") $ path wpcCbitsPath - capiStubsPathList <- forM (maybeToList unitArtifactsDir) $ \path -> do - findIfExists always (extension ==? ".dyn_o") $ path wpcCapiStubsPath + capiStubsPathList <- forM (maybeToList unitArtifactsDir) $ \path -> findIfExists always (extension ==? ".dyn_o") $ path wpcCapiStubsPath pure $ StgLibLinkerInfo { stglibName = unitName @@ -312,11 +337,11 @@ getAppLinkerInfo ghcStgAppFname = do } pure (appInfo, libInfoList) -data StgAppLicenseInfo +newtype StgAppLicenseInfo = StgAppLicenseInfo { stgappUnitConfs :: [FilePath] } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) getAppLicenseInfo :: FilePath -> IO StgAppLicenseInfo getAppLicenseInfo ghcStgAppFname = do @@ -327,10 +352,9 @@ getAppLicenseInfo ghcStgAppFname = do | confName <- unitId : [libName | 'H':'S':libName <- unitLibraries] , confPath <- appUnitDbPaths ] - unitConfs <- forM possibleUnitConfs $ \p -> do - doesFileExist p >>= \case - True -> pure $ Just p - False -> pure Nothing + unitConfs <- forM possibleUnitConfs $ \p -> doesFileExist p >>= \case + True -> pure $ Just p + False -> pure Nothing -- NOTE: report errors, but never fail. case catMaybes unitConfs of c : _ -> pure $ Just c -- HINT: pick the first match @@ -345,17 +369,16 @@ getAppLicenseInfo ghcStgAppFname = do data StgAppInfo = StgAppInfo - { _appIncludePaths :: [String] - , _appLibPaths :: [String] - , _appLdOptions :: [String] - , _appCLikeObjFiles :: [String] - , _appNoHsMain :: Bool + { _appIncludePaths :: [String] + , _appLibPaths :: [String] + , _appLdOptions :: [String] + , _appCLikeObjFiles :: [String] + , _appNoHsMain :: Bool } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) getAppInfo :: FilePath -> IO StgAppInfo -getAppInfo ghcStgAppFname = do - pure undefined +getAppInfo _ghcStgAppFname = pure undefined -- observation of foreign cbits source files @@ -365,7 +388,7 @@ data StgAppForeignSourceInfo , stgForeignSourceRelPath :: FilePath , stgForeignUnitId :: String } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) getAppForeignFiles :: FilePath -> IO [StgAppForeignSourceInfo] getAppForeignFiles ghcStgAppFname = do @@ -380,20 +403,19 @@ getAppForeignFiles ghcStgAppFname = do } | p <- appCbitsSources ] - libsCbitsInfos <- forM appLibDeps $ \UnitLinkerInfo{..} -> do - forM (maybeToList unitArtifactsDir) $ \path -> do - let libSrcDir = path wpcCbitsSourcePath - libCbitsSources <- findIfExists always (fileType ==? RegularFile) libSrcDir - pure - [ StgAppForeignSourceInfo - { stgForeignSourceAbsPath = p - , stgForeignSourceRelPath = makeRelative libSrcDir p - , stgForeignUnitId = unitId - } - | p <- libCbitsSources - ] + libsCbitsInfos <- forM appLibDeps $ \UnitLinkerInfo{..} -> forM (maybeToList unitArtifactsDir) $ \path -> do + let libSrcDir = path wpcCbitsSourcePath + libCbitsSources <- findIfExists always (fileType ==? RegularFile) libSrcDir + pure + [ StgAppForeignSourceInfo + { stgForeignSourceAbsPath = p + , stgForeignSourceRelPath = makeRelative libSrcDir p + , stgForeignUnitId = unitId + } + | p <- libCbitsSources + ] - pure $ appCbitsInfos ++ (concat $ concat libsCbitsInfos) + pure $ appCbitsInfos ++ concat (concat libsCbitsInfos) readGhcStgApp :: FilePath -> IO GhcStgApp readGhcStgApp fname = do @@ -470,14 +492,15 @@ getFoundationPakForGhcStgApp ghcstgapp = do data PakUnitInfo = PakUnitInfo - { pakUnitName :: String - , pakUnitVersion :: String - , pakUnitId :: String - , pakUnitDir :: FilePath + { pakUnitName :: String + , pakUnitVersion :: String + , pakUnitId :: String + , pakUnitDir :: FilePath } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) instance FromJSON PakUnitInfo where + parseJSON :: Y.Value -> Y.Parser PakUnitInfo parseJSON (Y.Object v) = PakUnitInfo <$> v .: "name" @@ -491,9 +514,10 @@ data PakYaml { pakyamlPathPrefix :: FilePath , pakyamlPackages :: [PakUnitInfo] } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) instance FromJSON PakYaml where + parseJSON :: Y.Value -> Y.Parser PakYaml parseJSON (Y.Object v) = PakYaml <$> v .: "path-prefix" @@ -507,15 +531,18 @@ foundationPakURL = "https://github.com/grin-compiler/foundation-pak/releases/dow downloadFoundationPakIfMissing :: String -> FilePath -> IO () downloadFoundationPakIfMissing ghcVersionString foundationPakPath = do exists <- doesDirectoryExist foundationPakPath - when (not exists) $ do + unless exists $ do let (pakDir, pakName) = splitFileName foundationPakPath - pakFileName = pakName <.> ".pak.tar.xz" + pakFileName = pakName <.> ".pak.tar.zst" pakURL = foundationPakURL ghcVersionString pakFileName printf "downloading %s into %s\n" pakURL pakDir createDirectoryIfMissing True pakDir - callCommand $ printf "(cd %s ; curl -L %s -o %s)" pakDir pakURL pakFileName - callCommand $ printf "(cd %s ; tar xf %s)" pakDir pakFileName - callCommand $ printf "(cd %s ; rm %s)" pakDir pakFileName + callCommand $ + printf "(cd %s ; curl -L %s -o %s)" pakDir pakURL pakFileName + callCommand $ + printf "(cd %s ; tar --use-compress-program=unzstd xf %s)" pakDir pakFileName + callCommand $ + printf "(cd %s ; rm %s)" pakDir pakFileName -- fullpak related @@ -525,9 +552,10 @@ data CodeInfo , ciUnitId :: String , ciModuleName :: String } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) instance FromJSON CodeInfo where + parseJSON :: Y.Value -> Y.Parser CodeInfo parseJSON (Y.Object v) = CodeInfo <$> v .: "package-name" @@ -536,6 +564,7 @@ instance FromJSON CodeInfo where parseJSON _ = fail "Expected Object for CodeInfo value" instance ToJSON CodeInfo where + toJSON :: CodeInfo -> Y.Value toJSON CodeInfo{..} = object [ "package-name" .= ciPackageName @@ -543,19 +572,21 @@ instance ToJSON CodeInfo where , "module-name" .= ciModuleName ] -data AppInfo +newtype AppInfo = AppInfo { aiLiveCode :: [CodeInfo] } - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) instance FromJSON AppInfo where + parseJSON :: Y.Value -> Y.Parser AppInfo parseJSON (Y.Object v) = AppInfo <$> v .: "live-code" parseJSON _ = fail "Expected Object for AppInfo value" instance ToJSON AppInfo where + toJSON :: AppInfo -> Y.Value toJSON AppInfo{..} = object [ "live-code" .= aiLiveCode diff --git a/external-stg/lib/Stg/Reconstruct.hs b/external-stg/lib/Stg/Reconstruct.hs index 3ff80e2..1f475bb 100644 --- a/external-stg/lib/Stg/Reconstruct.hs +++ b/external-stg/lib/Stg/Reconstruct.hs @@ -1,31 +1,52 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Stg.Reconstruct (reconModule, topBindings) where -import Data.Foldable -import Data.Bifunctor -import Prelude hiding (readFile) +import Control.Applicative ((<$>)) +import Control.Monad (Functor (..)) + +import Data.Bool (Bool (..)) +import Data.Foldable (Foldable (..), concatMap) +import Data.Function (flip, ($), (.)) +import Data.Hashable (Hashable (..)) +import qualified Data.HashMap.Lazy as HM +import Data.Int (Int) +import Data.List (unlines, zip, (++)) +import Data.Maybe (Maybe (..)) +import Data.Tuple (fst, snd) + +import GHC.Err (error) -import Data.Hashable -import qualified Data.HashMap.Lazy as HM +import Stg.Syntax (Alt, Alt' (..), AltCon, AltCon' (..), AltType, AltType' (..), Arg, Arg' (..), + Binder (..), BinderId (..), Binding, Binding' (..), CutTyCon (..), DataCon (..), + DataConId (..), Expr, Expr' (..), ForeignStubs, ForeignStubs' (..), Module, + Module' (..), ModuleName, Rhs, Rhs' (..), SAlt, SAltCon, SAltType, SArg, + SBinder (..), SBinding, SDataCon (..), SExpr, SForeignStubs, SModule, SRhs, + SStubDecl, STopBinding, STyCon (..), Scope (..), StubDecl, StubDecl' (..), + TopBinding, TopBinding' (..), TyCon (..), TyConId (..), Unique (..), UnitId, + mkBinderUniqueName, mkDataConUniqueName, mkTyConUniqueName) -import Stg.Syntax +import Text.Show (Show (..)) instance Hashable BinderId where + hashWithSalt :: Int -> BinderId -> Int hashWithSalt salt (BinderId (Unique c i)) = salt `hashWithSalt` c `hashWithSalt` i instance Hashable DataConId where + hashWithSalt :: Int -> DataConId -> Int hashWithSalt salt (DataConId (Unique c i)) = salt `hashWithSalt` c `hashWithSalt` i instance Hashable TyConId where + hashWithSalt :: Int -> TyConId -> Int hashWithSalt salt (TyConId (Unique c i)) = salt `hashWithSalt` c `hashWithSalt` i data BinderMap = BinderMap - { bmUnitId :: UnitId - , bmModule :: ModuleName - , bmIdMap :: HM.HashMap BinderId Binder - , bmDataConMap :: HM.HashMap DataConId DataCon - , bmTyConMap :: HM.HashMap TyConId TyCon + { bmUnitId :: UnitId + , bmModule :: ModuleName + , bmIdMap :: HM.HashMap BinderId Binder + , bmDataConMap :: HM.HashMap DataConId DataCon + , bmTyConMap :: HM.HashMap TyConId TyCon } -- Id handling @@ -38,28 +59,30 @@ insertBinders bs bm = foldl' (flip insertBinder) bm bs getBinder :: BinderMap -> BinderId -> Binder getBinder BinderMap{..} bid = case HM.lookup bid bmIdMap of Just b -> b - Nothing -> error $ "unknown binder "++ show bid ++ ":\nin scope:\n" ++ - unlines (map (\(bid',b) -> show bid' ++ "\t" ++ show b) (HM.toList bmIdMap)) + Nothing -> error $ "unknown binder " ++ show bid ++ ":\nin scope:\n" ++ + unlines (fmap (\(bid',b) -> show bid' ++ "\t" ++ show b) (HM.toList bmIdMap)) +{- -- DataCon handling insertDataCon :: DataCon -> BinderMap -> BinderMap insertDataCon dc bm@BinderMap{..} = bm {bmDataConMap = HM.insert (dcId dc) dc bmDataConMap} insertDataCons :: [DataCon] -> BinderMap -> BinderMap insertDataCons dcs bm = foldl' (flip insertDataCon) bm dcs +-} getDataCon :: BinderMap -> DataConId -> DataCon getDataCon BinderMap{..} bid = case HM.lookup bid bmDataConMap of Just b -> b Nothing -> error $ "unknown data con "++ show bid ++ ":\nin scope:\n" ++ - unlines (map (\(bid',b) -> show bid' ++ "\t" ++ show b) (HM.toList bmDataConMap)) + unlines (fmap (\(bid',b) -> show bid' ++ "\t" ++ show b) (HM.toList bmDataConMap)) -- TyCon handling getTyCon :: BinderMap -> TyConId -> TyCon getTyCon BinderMap{..} i = case HM.lookup i bmTyConMap of Just b -> b Nothing -> error $ "unknown ty con "++ show i ++ ":\nin scope:\n" ++ - unlines (map (\(i',b) -> show i' ++ "\t" ++ show b) (HM.toList bmTyConMap)) + unlines (fmap (\(i',b) -> show i' ++ "\t" ++ show b) (HM.toList bmTyConMap)) @@ -104,7 +127,7 @@ reconTyCon u m stc@STyCon{..} = tc where , tcId = stcId , tcUnitId = u , tcModule = m - , tcDataCons = map (reconDataCon u m tc) stcDataCons + , tcDataCons = fmap (reconDataCon u m tc) stcDataCons , tcDefLoc = stcDefLoc , tcUniqueName = uName , tcUNameHash = hash uName @@ -158,13 +181,13 @@ reconModule Module{..} = mod where cons = concatMap tcDataCons tyCons tyConList :: [(UnitId, [(ModuleName, [TyCon])])] - tyConList = [(u, [(m, map (reconTyCon u m) l) | (m, l) <- ml]) | (u, ml) <- moduleTyCons] + tyConList = [(u, [(m, fmap (reconTyCon u m) l) | (m, l) <- ml]) | (u, ml) <- moduleTyCons] stubs :: ForeignStubs stubs = reconForeignStubs bm moduleForeignStubs binds :: [TopBinding] - binds = map reconTopBinding moduleTopBindings + binds = fmap reconTopBinding moduleTopBindings tops :: [Binder] tops = [ mkTopBinder moduleUnitId moduleName sbinderScope b @@ -172,7 +195,7 @@ reconModule Module{..} = mod where ] exts :: [(UnitId, [(ModuleName, [Binder])])] - exts = [(u, [(m, map (mkTopBinder u m ModulePublic) l) | (m, l) <- ml]) | (u, ml) <- moduleExternalTopIds] + exts = [(u, [(m, fmap (mkTopBinder u m ModulePublic) l) | (m, l) <- ml]) | (u, ml) <- moduleExternalTopIds] reconTopBinder :: SBinder -> Binder reconTopBinder b = getBinder bm $ sbinderId b @@ -186,7 +209,7 @@ reconModule Module{..} = mod where reconForeignStubs :: BinderMap -> SForeignStubs -> ForeignStubs reconForeignStubs bm = \case NoStubs -> NoStubs - ForeignStubs h c i f l -> ForeignStubs h c i f $ map (reconStubDecl bm) l + ForeignStubs h c i f l -> ForeignStubs h c i f $ fmap (reconStubDecl bm) l reconStubDecl :: BinderMap -> SStubDecl -> StubDecl reconStubDecl bm = \case @@ -196,7 +219,7 @@ reconStubDecl bm = \case topBindings :: TopBinding' idBnd idOcc dcOcc tcOcc -> [idBnd] topBindings = \case StgTopLifted (StgNonRec b _) -> [b] - StgTopLifted (StgRec bs) -> map fst bs + StgTopLifted (StgRec bs) -> fmap fst bs StgTopStringLit b _ -> [b] reconExpr :: BinderMap -> SExpr -> Expr @@ -204,10 +227,10 @@ reconExpr bm = \case StgLit l -> StgLit l StgCase x b at alts -> let b' = reconLocalBinder bm b bm' = insertBinder b' bm - in StgCase (reconExpr bm x) b' (reconAltType bm at) (map (reconAlt bm') alts) - StgApp f args -> StgApp (getBinder bm f) (map (reconArg bm) args) - StgOpApp op args t tc -> StgOpApp op (map (reconArg bm) args) t (getTyCon bm <$> tc) - StgConApp dc args t -> StgConApp (getDataCon bm dc) (map (reconArg bm) args) t + in StgCase (reconExpr bm x) b' (reconAltType bm at) (fmap (reconAlt bm') alts) + StgApp f args -> StgApp (getBinder bm f) (fmap (reconArg bm) args) + StgOpApp op args t tc -> StgOpApp op (fmap (reconArg bm) args) t (getTyCon bm <$> tc) + StgConApp dc args t -> StgConApp (getDataCon bm dc) (fmap (reconArg bm) args) t StgLet b e -> let (bm', b') = reconBinding bm b in StgLet b' (reconExpr bm' e) StgLetNoEscape b e -> let (bm', b') = reconBinding bm b @@ -219,15 +242,15 @@ reconBinding bm = \case StgNonRec b r -> let b' = reconLocalBinder bm b bm' = insertBinder b' bm in (bm', StgNonRec b' (reconRhs bm' r)) - StgRec bs -> let bs' = map (reconLocalBinder bm . fst) bs + StgRec bs -> let bs' = fmap (reconLocalBinder bm . fst) bs bm' = insertBinders bs' bm in (bm', StgRec [(b, reconRhs bm' r) | ((_,r), b) <- zip bs bs']) reconRhs :: BinderMap -> SRhs -> Rhs reconRhs bm = \case - StgRhsCon dc vs -> StgRhsCon (getDataCon bm dc) $ map (reconArg bm) vs - StgRhsClosure fs u bs e -> let fs' = map (getBinder bm) fs - bs' = map (reconLocalBinder bm) bs + StgRhsCon dc vs -> StgRhsCon (getDataCon bm dc) $ fmap (reconArg bm) vs + StgRhsClosure fs u bs e -> let fs' = fmap (getBinder bm) fs + bs' = fmap (reconLocalBinder bm) bs bm' = insertBinders bs' bm in StgRhsClosure fs' u bs' (reconExpr bm' e) @@ -238,7 +261,7 @@ reconArg bm = \case reconAlt :: BinderMap -> SAlt -> Alt reconAlt bm (Alt con bs rhs) = - let bs' = map (reconLocalBinder bm) bs + let bs' = fmap (reconLocalBinder bm) bs bm' = insertBinders bs' bm in Alt (reconAltCon bm con) bs' (reconExpr bm' rhs) diff --git a/external-stg/lib/Stg/Tickish.hs b/external-stg/lib/Stg/Tickish.hs index fa2b46a..a9126c1 100644 --- a/external-stg/lib/Stg/Tickish.hs +++ b/external-stg/lib/Stg/Tickish.hs @@ -1,10 +1,20 @@ -{-# LANGUAGE LambdaCase #-} module Stg.Tickish where -import Control.Monad.RWS hiding (Alt) +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..), mapM_, sequence_) +import Control.Monad.RWS (MonadReader (..), MonadWriter (..), RWS, evalRWS) -import Stg.Syntax -import Stg.IRLocation +import Data.Function (const, ($)) +import Data.Int (Int) +import Data.List (zip) +import Data.Maybe (Maybe (..)) +import Data.Tuple (snd, uncurry) + +import GHC.Err (error) + +import Stg.IRLocation (StgPoint (..), binderToStgId) +import Stg.Syntax (Alt, Alt' (..), Binder, Binding, Binding' (..), Expr, Expr' (..), Id (..), Module, + Module' (..), Rhs, Rhs' (..), Tickish, TopBinding, TopBinding' (..)) type M = RWS (Maybe StgPoint) [(StgPoint, Tickish)] () diff --git a/ghc-wpc-testsuite-ci/hello/hello.cabal b/ghc-wpc-testsuite-ci/hello/hello.cabal index e16d162..42cb224 100644 --- a/ghc-wpc-testsuite-ci/hello/hello.cabal +++ b/ghc-wpc-testsuite-ci/hello/hello.cabal @@ -1,22 +1,28 @@ -- Initial minigame.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ +cabal-version: 3.14 name: hello version: 0.1.0.0 -- synopsis: -- description: -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Csaba Hruska maintainer: csaba.hruska@gmail.com -- copyright: -- category: build-type: Simple --- extra-source-files: -cabal-version: >=1.10 +-- extra-source-files: executable hello main-is: Main.hs build-depends: base, vector, random -- hs-source-dirs: - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards diff --git a/ghc-wpc-testsuite-ci/hie.yaml b/ghc-wpc-testsuite-ci/hie.yaml new file mode 100644 index 0000000..6c13fc6 --- /dev/null +++ b/ghc-wpc-testsuite-ci/hie.yaml @@ -0,0 +1,4 @@ +cradle: + stack: + - path: "hello/./Main.hs" + component: "hello:exe:hello" diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..4a23be4 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,28 @@ +cradle: + cabal: + - path: "external-stg/lib" + component: "lib:external-stg" + + - path: "external-stg/app/ext-stg.hs" + component: "external-stg:exe:ext-stg" + + - path: "external-stg/app/stgapp.hs" + component: "external-stg:exe:stgapp" + + - path: "external-stg/app/mkfullpak.hs" + component: "external-stg:exe:mkfullpak" + + - path: "external-stg-interpreter/lib" + component: "lib:external-stg-interpreter" + + - path: "external-stg-interpreter/app/ExtStgInterpreter.hs" + component: "external-stg-interpreter:exe:ext-stg-interpreter" + + - path: "external-stg-interpreter/app/RunStgiTestsuite.hs" + component: "external-stg-interpreter:exe:run-stgi-testsuite" + + - path: "external-stg-interpreter/test" + component: "external-stg-interpreter:test:primop-test" + + - path: "external-stg-syntax/lib" + component: "lib:external-stg-syntax" diff --git a/lambda/app/mklampak.hs b/lambda/app/mklampak.hs index f2f2591..d6e6394 100644 --- a/lambda/app/mklampak.hs +++ b/lambda/app/mklampak.hs @@ -59,7 +59,7 @@ main = do createArchive lampakName $ do -- top level info let content = BS8.pack $ unlines - [ "modules:", Stg.printSection $ map (Stg.getModuleName . Stg.moduleName) mods + [ "modules:", Stg.printSection $ fmap (Stg.getModuleName . Stg.moduleName) mods ] addZstdEntry "app.info" content diff --git a/lambda/app/strip-fullpak.hs b/lambda/app/strip-fullpak.hs index 1e8fc8d..ddda385 100644 --- a/lambda/app/strip-fullpak.hs +++ b/lambda/app/strip-fullpak.hs @@ -122,7 +122,7 @@ addZstdEntry path content = do -} readNameMap :: BS8.ByteString -> (Map BS8.ByteString BS8.ByteString, Map BS8.ByteString [BS8.ByteString]) -readNameMap content = foldl' go mempty . map BS8.words $ BS8.lines content where +readNameMap content = foldl' go mempty . fmap BS8.words $ BS8.lines content where go (bMap, aMap) = \case [] -> (bMap, aMap) ["b", stgName, lambdaName] -> (Map.insert stgName lambdaName bMap, aMap) diff --git a/lambda/hie.yaml b/lambda/hie.yaml new file mode 100644 index 0000000..f77819d --- /dev/null +++ b/lambda/hie.yaml @@ -0,0 +1,19 @@ +cradle: + cabal: + - path: "src" + component: "lib:lambda" + + - path: "test" + component: "lambda:test:lambda-test" + + - path: "app/mklampak.hs" + component: "lambda:exe:mklampak" + + - path: "app/mkfacts.hs" + component: "lambda:exe:mkfacts" + + - path: "app/strip-fullpak.hs" + component: "lambda:exe:strip-fullpak" + + - path: "app/catlambda.hs" + component: "lambda:exe:catlambda" diff --git a/lambda/lambda.cabal b/lambda/lambda.cabal index ac3bb0b..2967e39 100644 --- a/lambda/lambda.cabal +++ b/lambda/lambda.cabal @@ -1,8 +1,9 @@ +cabal-version: 3.14 name: lambda version: 0.1.0.0 homepage: https://github.com/grin-compiler/ghc-whole-program-compiler-project -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Csaba Hruska, Andor Penzes maintainer: csaba.hruska@gmail.com @@ -10,8 +11,6 @@ copyright: 2021 Csaba Hruska category: Compiler build-type: Simple -cabal-version: >=1.10 - library hs-source-dirs: src exposed-modules: @@ -39,7 +38,7 @@ library , mtl , bytestring , recursion-schemes - , ansi-wl-pprint + , prettyprinter-compat-ansi-wl-pprint , megaparsec , neat-interpolation , text @@ -53,10 +52,17 @@ library , comonad , binary , external-stg + , external-stg-syntax , transformers , hashable - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards source-repository head @@ -85,7 +91,7 @@ test-suite lambda-test , microlens , transformers , mtl - , ansi-wl-pprint + , prettyprinter-compat-ansi-wl-pprint , pretty-show , directory , inline-c @@ -102,10 +108,22 @@ test-suite lambda-test PrimOpStablePtrSpec PrimOpSTMSpec PrimOpWeakPtrSpec - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards executable mklampak - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards hs-source-dirs: app main-is: mklampak.hs build-depends: base @@ -118,13 +136,20 @@ executable mklampak , mtl , bytestring , binary - , ansi-wl-pprint + , prettyprinter-compat-ansi-wl-pprint , zip , external-stg + , external-stg-syntax , lambda executable mkfacts - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards hs-source-dirs: app main-is: mkfacts.hs build-depends: base @@ -136,9 +161,16 @@ executable mkfacts , bytestring , zip , external-stg + , external-stg-syntax executable strip-fullpak - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards hs-source-dirs: app main-is: strip-fullpak.hs build-depends: base @@ -152,10 +184,17 @@ executable strip-fullpak , binary , zip , external-stg + , external-stg-syntax , lambda executable catlambda - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards hs-source-dirs: app main-is: catlambda.hs build-depends: base @@ -167,3 +206,4 @@ executable catlambda , bytestring , zip , external-stg + , external-stg-syntax diff --git a/lambda/preprocess-ghc-primops/Gen.hs b/lambda/preprocess-ghc-primops/Gen.hs index 7484055..a4cc0a3 100644 --- a/lambda/preprocess-ghc-primops/Gen.hs +++ b/lambda/preprocess-ghc-primops/Gen.hs @@ -163,7 +163,7 @@ type G = State Env attr :: [Option] -> (Option -> Maybe a) -> G a attr opts f = do defaults <- gets envDefaults - pure $ head $ catMaybes $ map f (opts ++ defaults) + pure $ head $ catMaybes $ fmap f (opts ++ defaults) attrBool :: String -> [Option] -> G Bool attrBool name opts = attr opts $ \case @@ -248,7 +248,7 @@ genGHCPrimOps = do primPrelude = [ "primPrelude :: Program" , "primPrelude = [progConst|" - ] ++ map tab (concat [comment title ++ (lines $ showWidth 800 $ plain $ L.prettyExternals exts) ++ [""] | (title, exts, _) <- envSections]) ++ + ] ++ fmap tab (concat [comment title ++ (lines $ showWidth 800 $ plain $ L.prettyExternals exts) ++ [""] | (title, exts, _) <- envSections]) ++ [" |]\n"] unsupported = @@ -279,7 +279,7 @@ genGHCPrimOps = do no - transform primop names to GHC:op_name no - transform primtype names to GHC:type_name done - filter out void representations from the result ; State# - done - map unboxed tuples properly + done - fmap unboxed tuples properly -} {- STG state convention: diff --git a/lambda/preprocess-ghc-primops/genprimopcode/Parser.hs b/lambda/preprocess-ghc-primops/genprimopcode/Parser.hs index 11f24d7..2909ad8 100644 --- a/lambda/preprocess-ghc-primops/genprimopcode/Parser.hs +++ b/lambda/preprocess-ghc-primops/genprimopcode/Parser.hs @@ -230,7 +230,7 @@ happyExpListPerState st = bit_start = st * 72 bit_end = (st + 1) * 72 read_bit = readArrayBit happyExpList - bits = map read_bit [bit_start..bit_end - 1] + bits = fmap read_bit [bit_start..bit_end - 1] bits_indexed = zip bits [0..71] token_strs_expected = concatMap f bits_indexed f (False, _) = [] @@ -1471,7 +1471,6 @@ happyFail 0# tk old_st (HappyCons ((action)) (sts)) (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} -- Enter error recovery: generate an error token, -- save the old token and carry on. diff --git a/lambda/preprocess-ghc-primops/genprimopcode/Syntax.hs b/lambda/preprocess-ghc-primops/genprimopcode/Syntax.hs index 4dc6e7b..97e9579 100644 --- a/lambda/preprocess-ghc-primops/genprimopcode/Syntax.hs +++ b/lambda/preprocess-ghc-primops/genprimopcode/Syntax.hs @@ -128,7 +128,7 @@ myseqAll [] x = x sanityTop :: Info -> () sanityTop (Info defs entries) - = let opt_names = map get_attrib_name defs + = let opt_names = fmap get_attrib_name defs primops = filter is_primop entries in if length opt_names /= length (nub opt_names) @@ -137,7 +137,7 @@ sanityTop (Info defs entries) sanityPrimOp :: [String] -> Entry -> () sanityPrimOp def_names p - = let p_names = map get_attrib_name (opts p) + = let p_names = fmap get_attrib_name (opts p) p_names_ok = length p_names == length (nub p_names) && all (`elem` def_names) p_names diff --git a/lambda/preprocess-ghc-primops/ghc-primop-gen.cabal b/lambda/preprocess-ghc-primops/ghc-primop-gen.cabal index 466be34..fa8593b 100644 --- a/lambda/preprocess-ghc-primops/ghc-primop-gen.cabal +++ b/lambda/preprocess-ghc-primops/ghc-primop-gen.cabal @@ -1,7 +1,8 @@ +cabal-version: 3.14 Name: ghc-primop-gen Version: 0.1 Copyright: XXX -License: BSD3 +License: BSD-3-Clause -- XXX License-File: LICENSE Author: XXX Maintainer: XXX @@ -15,7 +16,6 @@ Description: * an LaTeX document describing the primitive operations. Category: Development build-type: Simple -cabal-version: >=1.10 library hs-source-dirs: . genprimopcode @@ -30,8 +30,14 @@ library array, containers, mtl, - ansi-wl-pprint, + prettyprinter-compat-ansi-wl-pprint, pretty-show, lambda - default-language: Haskell2010 + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards diff --git a/lambda/src/Lambda/Analysis/ControlFlowAnalysisM.hs b/lambda/src/Lambda/Analysis/ControlFlowAnalysisM.hs index 2195f35..7534e52 100644 --- a/lambda/src/Lambda/Analysis/ControlFlowAnalysisM.hs +++ b/lambda/src/Lambda/Analysis/ControlFlowAnalysisM.hs @@ -55,6 +55,6 @@ controlFlowAnalysisImplM log calledByOuterCode initialReachable prg = do result <- filter (\n -> takeExtension n == ".csv") <$> listDirectory tmpCfa Map.fromList <$> forM result (\fname -> do - row <- map (Text.splitOn "\t") . Text.lines <$> Text.readFile (tmpCfa fname) + row <- fmap (Text.splitOn "\t") . Text.lines <$> Text.readFile (tmpCfa fname) pure (takeBaseName fname, row) ) diff --git a/lambda/src/Lambda/Datalog/ToDatalog.hs b/lambda/src/Lambda/Datalog/ToDatalog.hs index b02895e..6c144c5 100644 --- a/lambda/src/Lambda/Datalog/ToDatalog.hs +++ b/lambda/src/Lambda/Datalog/ToDatalog.hs @@ -67,7 +67,7 @@ programToFactsM log outDir prg = do hClose h toDatalog :: [Fact] -> String -toDatalog = unlines . map prettyFact where +toDatalog = unlines . fmap prettyFact where prettyFact :: Fact -> String prettyFact (n, args) = n ++ "(" ++ intercalate ", " (map showParam args) ++ ")." @@ -78,7 +78,7 @@ toDatalog = unlines . map prettyFact where N n -> show $ unpackName n toFacts :: [Fact] -> [(String, String)] -toFacts = map prettyFacts . Map.toList . Map.unionsWith (++) . map (\(f,a) -> Map.singleton f [a]) where +toFacts = fmap prettyFacts . Map.toList . Map.unionsWith (++) . fmap (\(f,a) -> Map.singleton f [a]) where factEq a b = fst a == fst b prettyFacts :: (String, [[Param]]) -> (String, String) diff --git a/lambda/src/Lambda/Lint.hs b/lambda/src/Lambda/Lint.hs index 7b5a59f..0ec2646 100644 --- a/lambda/src/Lambda/Lint.hs +++ b/lambda/src/Lambda/Lint.hs @@ -27,13 +27,13 @@ lintLambda prg@Program{..} = do , Set.fromList [sName | StaticData{..} <- pStaticData] ] unknown = Set.difference envUse known - --printf "node pats:\n%s" . unlines . map tab $ Set.toList envCon + --printf "node pats:\n%s" . unlines . fmap tab $ Set.toList envCon - printf "unknown:\n%s" . unlines . map tab $ Set.toList unknown - printf "errors:\n%s" . unlines . map tab $ Set.toList envErr - --printf "unused:\n%s" . unlines . map show $ Set.toList (Set.difference envDef envUse) + printf "unknown:\n%s" . unlines . fmap tab $ Set.toList unknown + printf "errors:\n%s" . unlines . fmap tab $ Set.toList envErr + --printf "unused:\n%s" . unlines . fmap show $ Set.toList (Set.difference envDef envUse) let duplicates = [n | (n,i) <- Map.toList envDef, i > 1] - printf "duplicates:\n%s" . unlines . map tab $ duplicates + printf "duplicates:\n%s" . unlines . fmap tab $ duplicates data Env = Env @@ -54,7 +54,7 @@ env = Env } addDef n = Map.singleton n 1 -addDefs ns = Map.unionsWith (+) $ map addDef ns +addDefs ns = Map.unionsWith (+) $ fmap addDef ns addNames ns = Set.fromList ns @@ -64,7 +64,7 @@ test = cata folder where VarF name -> env {envUse = Set.singleton name} AppF name args -> env {envUse = addNames $ name : args} -- def - DefF name args e -> env {envDef = addDefs $ name : map fst args} <> e + DefF name args e -> env {envDef = addDefs $ name : fmap fst args} <> e LetRecF binds e -> mconcat [env {envDef = addDef name} <> a | (name, _, a) <- binds] <> e LetSF binds e -> mconcat [env {envDef = addDef name} <> a | (name, _, a) <- binds] <> e LetF binds e -> mconcat [env {envDef = addDef name} <> a | (name, _, a) <- binds] <> e diff --git a/lambda/src/Lambda/Pretty.hs b/lambda/src/Lambda/Pretty.hs index 177a411..04bd565 100644 --- a/lambda/src/Lambda/Pretty.hs +++ b/lambda/src/Lambda/Pretty.hs @@ -42,7 +42,7 @@ prettyBinderArg = parens . prettyBinder instance Pretty Exp where pretty prg = cata folder prg where extNames = case prg of - Program{..} -> Set.fromList $ map eName pExternals + Program{..} -> Set.fromList $ fmap eName pExternals _ -> Set.empty isPrimName n = Set.member n extNames @@ -52,23 +52,23 @@ instance Pretty Exp where : prettyPublicNames pPublicNamesF : prettyForeignExportedNames pForeignExportedNamesF : prettyStaticData pStaticDataF - : map pretty pDefinitionsF + : fmap pretty pDefinitionsF ) - DefF name args exp -> nest 2 (hsep (pretty name : map prettyBinderArg args) <+> text "=" <$$> pretty exp) <> line + DefF name args exp -> nest 2 (hsep (pretty name : fmap prettyBinderArg args) <+> text "=" <$$> pretty exp) <> line -- Exp - AppF name args -> hsep (((if isPrimName name then dullyellow else cyan) $ pretty name) : text "$" : map pretty args) + AppF name args -> hsep (((if isPrimName name then dullyellow else cyan) $ pretty name) : text "$" : fmap pretty args) CaseF atom alts -> nest 2 (keyword "case" <+> pretty atom <+> keyword "of" <$$> vsep (map pretty alts)) LetF binds exp -> nest 2 (keyword "let" <$$> vsep (map prettyBind binds)) <$$> pretty exp LetRecF binds exp -> nest 2 (keyword "letrec" <$$> vsep (map prettyBind binds)) <$$> pretty exp LetSF binds exp -> nest 2 (keyword "letS" <$$> vsep (map prettyBind binds)) <$$> pretty exp - ConF tag args -> brackets $ hsep (pretty tag : map pretty args) + ConF tag args -> brackets $ hsep (pretty tag : fmap pretty args) -- Atom VarF name -> pretty name LitF lit -> pretty lit -- Alt AltF name cpat exp -> nest 2 (pretty cpat <+> text "@" <+> pretty name <+> text "->" <$$> pretty exp) -- Extra - ClosureF vars args exp -> nest 2 (keyword "\\closure" <+> hsep (brackets (hsep (map pretty vars)) : map prettyBinderArg args ++ [text "->"]) Leijen.<$> pretty exp) + ClosureF vars args exp -> nest 2 (keyword "\\closure" <+> hsep (brackets (hsep (map pretty vars)) : fmap prettyBinderArg args ++ [text "->"]) Leijen.<$> pretty exp) instance Pretty Lit where pretty = \case @@ -87,7 +87,7 @@ instance Pretty Lit where instance Pretty Pat where pretty = \case - NodePat tag vars -> parens $ hsep (pretty tag : map pretty vars) + NodePat tag vars -> parens $ hsep (pretty tag : fmap pretty vars) LitPat lit -> pretty lit DefaultPat -> keyword "_" @@ -104,7 +104,7 @@ prettyConGroups [] = mempty prettyConGroups cons = keyword "constructors" <$$> line <> vsep (map prettyConGroup cons) <> line prettyConGroup :: ConGroup -> Doc -prettyConGroup (ConGroup name cons) = indent 2 (keyword "data" <+> pretty name <$$> indent 2 (vsep $ map (prettyConSpec width) cons)) <> line where +prettyConGroup (ConGroup name cons) = indent 2 (keyword "data" <+> pretty name <$$> indent 2 (vsep $ fmap (prettyConSpec width) cons)) <> line where maxWidth = 80 maxLen = maximum [length . show . pretty $ csName s | s <- cons] width = min maxLen maxWidth @@ -115,7 +115,7 @@ prettyConSpec width (ConSpec name argsRep) = fill width (pretty name) <+> hsep ( prettyStaticData :: [StaticData] -> Doc prettyStaticData [] = mempty -prettyStaticData sdata = keyword "static" <+> keyword "data" <$$> indent 2 (vsep $ map (prettyStaticDataItem width) sdata) <> line where +prettyStaticData sdata = keyword "static" <+> keyword "data" <$$> indent 2 (vsep $ fmap (prettyStaticDataItem width) sdata) <> line where maxWidth = 80 maxLen = maximum [length . show . pretty $ sName s | s <- sdata] width = min maxLen maxWidth @@ -147,7 +147,7 @@ prettyFunction width name ret args = fill width (pretty name) <> align (myEnclos instance Pretty Ty where pretty = \case - TyCon varName name tys -> braces (hsep ((green $ pretty name) : map pretty tys)) <+> text "@" <+> pretty varName + TyCon varName name tys -> braces (hsep ((green $ pretty name) : fmap pretty tys)) <+> text "@" <+> pretty varName TyVar name -> text "%" <> cyan (pretty name) TySimple varName simpleType -> parens (pretty simpleType) <+> text "@" <+> pretty varName TyFun name retTy argsTy -> parens (pretty name <> (myEncloseSep (text " : ") empty (text " -> ") (map pretty $ argsTy ++ [retTy]))) @@ -163,7 +163,7 @@ instance Pretty PrimRep where instance Pretty RepType where pretty = \case SingleValue t -> pretty t - UnboxedTuple l -> braces (hsep $ map pretty l) + UnboxedTuple l -> braces (hsep $ fmap pretty l) PolymorphicRep -> red $ text "PolymorphicRep" Auto -> red $ text "Auto" diff --git a/lambda/src/Lambda/Stg/FromStg.hs b/lambda/src/Lambda/Stg/FromStg.hs index b73219e..8825616 100644 --- a/lambda/src/Lambda/Stg/FromStg.hs +++ b/lambda/src/Lambda/Stg/FromStg.hs @@ -12,6 +12,7 @@ import Text.Printf import qualified Data.ByteString.Char8 as BS8 import qualified Data.Text as T import Control.Monad.Trans.Maybe +import Control.Monad import Data.Functor.Foldable import qualified Data.Foldable @@ -62,7 +63,7 @@ data Env -- name shadowing related , scopeName :: Name -- HINT: current scope name - , shadowedNameMap :: !(Map Name Name) -- HINT: substitution map for shadowed names, original name -> unique name + , shadowedNameMap :: !(Map Name Name) -- HINT: substitution fmap for shadowed names, original name -> unique name , scopeShadowSet :: !(Set Name) -- HINT: shadowed (original) names defined in the current scope -- code name mapping @@ -99,7 +100,7 @@ addBinderNameMapEntry b name = do addAltNameMapEntry :: C.Binder -> [Name] -> CG () addAltNameMapEntry b altNames = do - let nameMapEntry = intercalate "\t" $ "a" : (BS8.unpack $ C.binderUniqueName b) : map unpackName altNames + let nameMapEntry = intercalate "\t" $ "a" : (BS8.unpack $ C.binderUniqueName b) : fmap unpackName altNames modify' $ \env@Env{..} -> env { codeNameMap = nameMapEntry : codeNameMap } scopeBracket :: Name -> CG a -> CG a @@ -130,7 +131,7 @@ refreshTyVars tys = do let substFun :: Ty -> Ty substFun t = ana (project . mapNameTy (subst $ Map.fromList substEnv)) t - pure $ map substFun tys + pure $ fmap substFun tys addExternal :: External -> CG () addExternal ext = modify' $ \env@Env{..} -> env {externals = Map.insert (eName ext) ext externals} @@ -246,7 +247,7 @@ isUnboxedTuple name = BS8.isPrefixOf "ghc-prim_GHC.Prim.(#" name convertType :: C.Type -> RepType convertType = \case C.SingleValue r -> SingleValue $ getPrimRep r - C.UnboxedTuple l -> UnboxedTuple $ map getPrimRep l + C.UnboxedTuple l -> UnboxedTuple $ fmap getPrimRep l C.PolymorphicRep -> PolymorphicRep getPrimRep :: C.PrimRep -> PrimRep @@ -363,7 +364,6 @@ ffiArgType = \case "ghc-prim_GHC.Prim.coercionToken#" -> pure (SO_Builtin, Void) "ghc-prim_GHC.Prim.proxy#" -> pure (SO_Builtin, Void) "ghc-prim_GHC.Prim.(##)" -> pure (SO_Builtin, Void) --} ffiRetType :: C.Type -> MaybeT CG Ty ffiRetType = \case @@ -451,7 +451,7 @@ mkConGroup :: C.UnitId -> C.ModuleName -> C.TyCon -> ConGroup mkConGroup u mod tc = ConGroup { cgName = mkPackageQualifiedName (BS8.unpack $ C.getUnitId u) (BS8.unpack $ C.getModuleName mod) (BS8.unpack $ C.tcName tc) - , cgCons = map (mkConSpec tc) $ C.tcDataCons tc + , cgCons = fmap (mkConSpec tc) $ C.tcDataCons tc } mkConSpec :: C.TyCon -> C.DataCon -> ConSpec @@ -459,7 +459,7 @@ mkConSpec tc C.DataCon{..} = ConSpec { csName = mkPackageQualifiedName (BS8.unpack $ C.getUnitId dcUnitId) (BS8.unpack $ C.getModuleName dcModule) (BS8.unpack dcName) , csArgsRep = case dcRep of - C.AlgDataCon l -> map getPrimRep l + C.AlgDataCon l -> fmap getPrimRep l C.UnboxedTupleCon n -> replicate n VoidRep } @@ -622,8 +622,8 @@ visitOpApp resultName op args ty mtc = do _ -> do let name = BS8.unpack labelName - argsTy = map showArgType args - argsHSTy = map showArgHSType args + argsTy = fmap showArgType args + argsHSTy = fmap showArgHSType args retTy = show ty errMsg = unlines [ "Unsupported foreign primitive type: " ++ name ++ " :: " ++ intercalate " -> " (argsTy ++ [retTy]) @@ -635,8 +635,8 @@ visitOpApp resultName op args ty mtc = do C.StgFCallOp f@C.ForeignCall{..} -> case foreignCTarget of C.DynamicTarget -> do - let (fnTy:argsTy) = map showArgType args - (fnHSTy:argsHSTy) = map showArgHSType args + let (fnTy:argsTy) = fmap showArgType args + (fnHSTy:argsHSTy) = fmap showArgHSType args retTy = show ty errMsg = unlines [ "DynamicTarget is not supported: (" ++ fnTy ++ ") :: " ++ intercalate " -> " (argsTy ++ [retTy]) @@ -661,8 +661,8 @@ visitOpApp resultName op args ty mtc = do _ -> do let name = BS8.unpack labelName - argsTy = map showArgType args - argsHSTy = map showArgHSType args + argsTy = fmap showArgType args + argsHSTy = fmap showArgHSType args retTy = show ty errMsg = unlines [ "Unsupported foreign function type: " ++ name ++ " :: " ++ intercalate " -> " (argsTy ++ [retTy]) diff --git a/lambda/src/Lambda/Stg/StripDeadCode.hs b/lambda/src/Lambda/Stg/StripDeadCode.hs index a6140d0..776e3cf 100644 --- a/lambda/src/Lambda/Stg/StripDeadCode.hs +++ b/lambda/src/Lambda/Stg/StripDeadCode.hs @@ -16,6 +16,7 @@ import qualified Data.Map as Map import Data.Hashable import Stg.Syntax +import Control.Monad data Env = Env @@ -372,7 +373,7 @@ dropEmpty l = [v | v@(_, b) <- l, not $ null b] stripTyCons :: Set Name -> Set Name -> [TyCon] -> SM [(UnitId, [(ModuleName, [TyCon])])] stripTyCons liveCons liveConGroups modTyCons = do Env{..} <- get - let modTyConSet = Set.fromList $ map TC modTyCons + let modTyConSet = Set.fromList $ fmap TC modTyCons refConTyConSet = Set.fromList [TC $ uncutTyCon dcTyCon | DC DataCon{..} <- Set.toList referredCons] allTyCons = [tc | TC tc <- Set.toList $ Set.unions [referredTyCons, refConTyConSet, modTyConSet]] @@ -436,9 +437,9 @@ calcDependencies unitId modName = do ] extDeps :: [(UnitId, ModuleName)] - extDeps = map fst extIds ++ extTyCons ++ extCons + extDeps = fmap fst extIds ++ extTyCons ++ extCons - deps = map (fmap (map fst)) . groupByUnitIdAndModule $ zip extDeps (repeat ()) + deps = fmap (fmap (map fst)) . groupByUnitIdAndModule $ zip extDeps (repeat ()) pure (deps, extGroups) @@ -447,7 +448,7 @@ calcDependencies unitId modName = do topLiftedBindings :: TopBinding' idBnd idOcc dcOcc tcOcc -> [idBnd] topLiftedBindings = \case StgTopLifted (StgNonRec b _) -> [b] - StgTopLifted (StgRec bs) -> map fst bs + StgTopLifted (StgRec bs) -> fmap fst bs StgTopStringLit _ _ -> [] groupByUnitIdAndModule :: Ord b => [((UnitId, ModuleName), b)] -> [(UnitId, [(ModuleName, [b])])] diff --git a/lambda/src/Lambda/TH.hs b/lambda/src/Lambda/TH.hs index 0dcd570..135d6a0 100644 --- a/lambda/src/Lambda/TH.hs +++ b/lambda/src/Lambda/TH.hs @@ -58,7 +58,7 @@ normalizeQQInput = trim . unindent' . tabsToSpaces unindentedHead = dropWhile (== ' ') head minimumTailIndent = minimumIndent . unlines $ tail unindentedTail = case minimumTailIndent of - Just indent -> map (drop indent) tail + Just indent -> fmap (drop indent) tail Nothing -> tail in unlines $ unindentedHead : unindentedTail [] -> [] @@ -72,7 +72,7 @@ dropWhileRev p = foldr (\x xs -> if p x && null xs then [] else x:xs) [] unindent :: [Char] -> [Char] unindent s = case minimumIndent s of - Just indent -> unlines . map (drop indent) . lines $ s + Just indent -> unlines . fmap (drop indent) . lines $ s Nothing -> s tabsToSpaces :: [Char] -> [Char] @@ -82,7 +82,7 @@ tabsToSpaces [] = [] minimumIndent :: [Char] -> Maybe Int minimumIndent = - listToMaybe . sort . map lineIndent + listToMaybe . sort . fmap lineIndent . filter (not . null . dropWhile isSpace) . lines -- | Amount of preceding spaces on first line diff --git a/lambda/src/Lambda/Transformation/StaticSingleAssignment.hs b/lambda/src/Lambda/Transformation/StaticSingleAssignment.hs index e024dd2..5a231ed 100644 --- a/lambda/src/Lambda/Transformation/StaticSingleAssignment.hs +++ b/lambda/src/Lambda/Transformation/StaticSingleAssignment.hs @@ -13,6 +13,7 @@ import Transformations.Names hiding (mkNameEnv) import Transformations.Util hiding (foldNameDefExpF) import Lambda.Syntax import Lambda.Util +import Control.Monad type Env = Map Name Name @@ -26,7 +27,7 @@ ssaExternal ext@External{..} = do substFun t = ana (project . mapNameTy (subst $ Map.fromList env)) t pure ext { eRetType = substFun eRetType - , eArgsType = map substFun eArgsType + , eArgsType = fmap substFun eArgsType } singleStaticAssignment :: Exp -> Exp @@ -54,7 +55,7 @@ singleStaticAssignment e = evalState (anaM build (mempty, e)) (mkNameEnv e) wher , pPublicNamesF = pPublicNames , pForeignExportedNamesF = pForeignExportedNames , pStaticDataF = pStaticData - , pDefinitionsF = map (env,) pDefinitions + , pDefinitionsF = fmap (env,) pDefinitions } -- name shadowing in the bind sequence @@ -68,7 +69,7 @@ singleStaticAssignment e = evalState (anaM build (mempty, e)) (mkNameEnv e) wher pure $ LetSF bs' (newEnv, e) LetRec bs e -> do - let ns = map fst3 bs + let ns = fmap fst3 bs newNs <- mapM deriveNewName ns let newEnv = addMany env $ zip ns newNs pure $ LetRecF [(n, t, (newEnv, b)) | (n, (_, t, b)) <- zip newNs bs] (newEnv, e) diff --git a/lambda/src/Lambda/Util.hs b/lambda/src/Lambda/Util.hs index b7b5895..1c085b3 100644 --- a/lambda/src/Lambda/Util.hs +++ b/lambda/src/Lambda/Util.hs @@ -20,19 +20,19 @@ foldLocalNameDefExp f = foldLocalNameDefExpF f . project foldLocalNameDefExpF :: (Monoid m) => (Name -> m) -> ExpF a -> m foldLocalNameDefExpF f = \case - DefF _ args _ -> mconcat $ map (f . fst) args + DefF _ args _ -> mconcat $ fmap (f . fst) args ProgramF{} -> mempty e -> foldNameDefExpF f e foldNameDefExpF :: (Monoid m) => (Name -> m) -> ExpF a -> m foldNameDefExpF f = \case - ProgramF{..} -> mconcat $ map (f . sName) pStaticDataF - DefF n args _ -> mconcat $ f n : map (f . fst) args - LetF bs _ -> mconcat $ map (f . fst3) bs - LetRecF bs _ -> mconcat $ map (f . fst3) bs - LetSF bs _ -> mconcat $ map (f . fst3) bs - AltF a (NodePat _ bs) _ -> mconcat $ f a : map f bs - ClosureF _ bs _ -> mconcat $ map (f . fst) bs + ProgramF{..} -> mconcat $ fmap (f . sName) pStaticDataF + DefF n args _ -> mconcat $ f n : fmap (f . fst) args + LetF bs _ -> mconcat $ fmap (f . fst3) bs + LetRecF bs _ -> mconcat $ fmap (f . fst3) bs + LetSF bs _ -> mconcat $ fmap (f . fst3) bs + AltF a (NodePat _ bs) _ -> mconcat $ f a : fmap f bs + ClosureF _ bs _ -> mconcat $ fmap (f . fst) bs _ -> mempty fst3 :: (a, b, c) -> a @@ -40,8 +40,8 @@ fst3 (a, _, _) = a mapNameExp :: (Name -> Name) -> Exp -> Exp mapNameExp f = \case - prg@Program{..} -> prg { pPublicNames = map f pPublicNames - , pForeignExportedNames = map f pForeignExportedNames + prg@Program{..} -> prg { pPublicNames = fmap f pPublicNames + , pForeignExportedNames = fmap f pForeignExportedNames , pStaticData = [sd {sName = f $ sName sd} | sd <- pStaticData] } Def n args e -> Def (f n) [(f a, t) | (a, t) <- args] e diff --git a/lambda/test/CFASpec.hs b/lambda/test/CFASpec.hs index 6814507..da300fe 100644 --- a/lambda/test/CFASpec.hs +++ b/lambda/test/CFASpec.hs @@ -1242,4 +1242,3 @@ PrimOp .decl MutVar(ext_result:Variable, ty_node:Variable, item:Variable) .decl StablePtr(ext_result:Variable, ty_node:Variable, item:Variable) --} diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index c3c6c23..0000000 --- a/stack.yaml +++ /dev/null @@ -1,17 +0,0 @@ -resolver: lts-20.18 - -packages: - - 'external-stg-syntax' - - 'external-stg' - - 'external-stg-interpreter' -# - 'lambda' -# - 'external-stg-compiler' - -extra-deps: - - dom-lt-0.2.3 - - souffle-haskell-3.5.1 - - type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 - - github: csabahruska/final-pretty-printer - commit: 5444974a2e0ee76abb790c85738a38f96696c908 - -allow-newer: true diff --git a/wpc-plugin/cabal.project b/wpc-plugin/cabal.project new file mode 100644 index 0000000..41a2f2f --- /dev/null +++ b/wpc-plugin/cabal.project @@ -0,0 +1 @@ +packages: * diff --git a/wpc-plugin/hie.yaml b/wpc-plugin/hie.yaml new file mode 100644 index 0000000..37bb886 --- /dev/null +++ b/wpc-plugin/hie.yaml @@ -0,0 +1,7 @@ +cradle: + cabal: + - path: "src" + component: "lib:wpc-plugin" + + - path: "src" + component: "wpc-plugin:lib:wpc-plugin" diff --git a/wpc-plugin/src/WPC/Foreign.hs b/wpc-plugin/src/WPC/Foreign.hs index 7061a8a..2030eb0 100644 --- a/wpc-plugin/src/WPC/Foreign.hs +++ b/wpc-plugin/src/WPC/Foreign.hs @@ -1,29 +1,40 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE LambdaCase #-} module WPC.Foreign where -import Control.Monad -import GHC.Plugins - -import GHC.Driver.Hooks -import Language.Haskell.Syntax.Decls -import GHC.HsToCore.Types -import GHC.Types.ForeignStubs -import GHC.Data.OrdList -import GHC.Hs.Extension -import GHC.Tc.Utils.Monad -import GHC.HsToCore.Foreign.Decl -import GHC.Types.ForeignCall -import GHC.Types.RepType -import GHC.Core.TyCo.Compare -import GHC.Core.TyCo.Rep -import GHC.Tc.Utils.TcType - -import WPC.GlobalEnv -import WPC.ForeignStubDecls -import Data.IORef -import Data.Maybe -import Data.List +import Control.Monad (Functor (..), forM) + +import Data.Bool (Bool (..), otherwise) +import Data.Function (($), (.)) +import Data.IORef (modifyIORef) +import Data.List (concat, concatMap, unzip3, (++)) +import Data.Maybe (Maybe (..), mapMaybe) +import Data.Monoid (Monoid (..)) +import Data.String (String) +import Data.Tuple (snd) + +import GHC.Core.TyCo.Rep (Scaled (..)) +import GHC.Data.OrdList (OrdList, fromOL) +import GHC.Driver.Hooks (Hooks (..)) +import GHC.Err (undefined) +import GHC.Hs.Extension (GhcTc) +import GHC.HsToCore.Foreign.Decl (dsForeigns) +import GHC.HsToCore.Types (DsM) +import GHC.Plugins (Alt (..), Bind (..), Coercion, CoreAlt, CoreBind, CoreExpr, Expr (..), + FastString, FunctionOrData (..), GenLocated (..), HscEnv (..), Id, + Literal (..), NamedThing (..), Outputable (..), TyCon, Type, + anonPiTyBinderType_maybe, coercionLKind, getOccString, liftIO, pprPanic, + tcSplitTyConApp_maybe, unLoc) +import GHC.Tc.Utils.Monad (Applicative (..), updTopEnv) +import GHC.Tc.Utils.TcType (tcSplitForAllInvisTyVars, tcSplitFunTys, tcSplitIOType_maybe, + tcSplitPiTys) +import GHC.Types.ForeignStubs (ForeignStubs) +import GHC.Types.RepType (unwrapType) + +import Language.Haskell.Syntax.Decls (CImportSpec (..), ForeignDecl (..), ForeignImport (..), LForeignDecl) + +import System.IO (putStrLn) + +import WPC.ForeignStubDecls (StubDecl (..), StubImpl (..), mergeForeignStubs) +import WPC.GlobalEnv (GlobalEnv (..), globalEnvIORef) dsForeignsFun :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)) dsForeignsFun fos = do @@ -43,7 +54,7 @@ dsForeignsFun fos = do pure (mergeForeignStubs stubList, mconcat bindingList) mkStubDecl :: ForeignStubs -> OrdList (Id, CoreExpr) -> LForeignDecl GhcTc -> (ForeignStubs, StubDecl) -mkStubDecl stub bindings (L loc decl) = case decl of +mkStubDecl stub bindings (L _loc decl) = case decl of ForeignImport{..} -> (stub, StubDeclImport fd_fi (mkStubImpl bindings decl)) ForeignExport{..} -> (stub, StubDeclExport fd_fe (unLoc fd_name)) @@ -51,7 +62,7 @@ mkStubImpl :: OrdList (Id, CoreExpr) -> ForeignDecl GhcTc -> Maybe StubImpl mkStubImpl bindings decl = case decl of ForeignImport{..} | CImport _srcText _cconv _safety _mHeader CWrapper <- fd_fi - , [wrapperCName] <- concat $ (map (getWrapperName . snd) $ fromOL bindings) + , [wrapperCName] <- concat $ (fmap (getWrapperName . snd) $ fromOL bindings) , (isIOCall, retTy, argTys) <- getCWrapperDescriptor fd_i_ext -> Just $ StubImplImportCWrapper { siCWrapperLabel = wrapperCName @@ -73,39 +84,43 @@ mkStubImpl bindings decl = case decl of getWrapperName :: CoreExpr -> [FastString] getWrapperName expr = case expr of - App e a -> getWrapperName e ++ getWrapperName a - Lam _ e -> getWrapperName e - Let b e -> goBind b ++ getWrapperName e - Case e _ _ l -> getWrapperName e ++ concatMap goAlt l - Cast e _ -> getWrapperName e - Tick _ e -> getWrapperName e - - Var{} -> [] - Lit (LitLabel fe_nm _mb_sz_args IsFunction) -> [fe_nm] - Lit{} -> [] - Type{} -> [] - Coercion{} -> [] + App e a -> getWrapperName e ++ getWrapperName a + Lam _ e -> getWrapperName e + Let b e -> goBind b ++ getWrapperName e + Case e _ _ l -> getWrapperName e ++ concatMap goAlt l + Cast e _ -> getWrapperName e + Tick _ e -> getWrapperName e + + Var{} -> [] + Lit (LitLabel fe_nm IsFunction) -> [fe_nm] + Lit{} -> [] + Type{} -> [] + Coercion{} -> [] getCWrapperDescriptor :: Coercion -> (Bool, String, [String]) -- is IO, result type, arg types -getCWrapperDescriptor ffiCo = (is_IO_res_ty, showFFIType res_ty, map showFFIType fe_arg_tys) +getCWrapperDescriptor ffiCo = (is_IO_res_ty, showFFIType res_ty, fmap showFFIType fe_arg_tys) where -- example for ffiTy: (Int -> IO Int) -> IO (FunPtr (Int -> IO Int)) - ffiTy = coercionLKind ffiCo - (_,sans_foralls) = tcSplitForAllInvisTyVars ffiTy + ffiTy = coercionLKind ffiCo + (_,sans_foralls) = tcSplitForAllInvisTyVars ffiTy -- example for arg_ty: Int -> IO Int - ([Scaled _ arg_ty], _) = tcSplitFunTys sans_foralls + Scaled _ arg_ty = case tcSplitFunTys sans_foralls of + ([], _) -> undefined + (a : _, _) -> a - (bndrs, orig_res_ty) = tcSplitPiTys arg_ty - fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs + + (bndrs, orig_res_ty) = tcSplitPiTys arg_ty + fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs -- Look at the result type of the exported function, orig_res_ty -- If it's IO t, return (t, True) -- If it's plain t, return (t, False) - (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of - -- The function already returns IO t - Just (_ioTyCon, res_ty) -> (res_ty, True) - -- The function returns t - Nothing -> (orig_res_ty, False) + (res_ty, is_IO_res_ty) = + case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty') -> (res_ty', True) + -- The function returns t + Nothing -> (orig_res_ty, False) showFFIType :: Type -> String showFFIType t = getOccString (getName (typeTyCon t)) diff --git a/wpc-plugin/src/WPC/ForeignStubDecls.hs b/wpc-plugin/src/WPC/ForeignStubDecls.hs index c890b1c..b6b5faa 100644 --- a/wpc-plugin/src/WPC/ForeignStubDecls.hs +++ b/wpc-plugin/src/WPC/ForeignStubDecls.hs @@ -1,21 +1,27 @@ module WPC.ForeignStubDecls where -import GHC.Plugins -import GHC.Types.ForeignStubs -import GHC.Types.ForeignCall -import GHC.Hs.Extension -import Language.Haskell.Syntax.Decls +import Data.Bool (Bool (..)) +import Data.Int (Int) +import Data.Maybe (Maybe) +import Data.Monoid (Monoid (..)) +import Data.String (String) + +import GHC.Hs.Extension (GhcTc) +import GHC.Plugins (FastString, Id) +import GHC.Types.ForeignStubs (ForeignStubs (..)) + +import Language.Haskell.Syntax.Decls (ForeignExport, ForeignImport) -- | Foreign export stub detailed declarations newtype ForeignStubDecls = ForeignStubDecls [(ForeignStubs, StubDecl)] data StubImpl = StubImplImportCWrapper - { siCWrapperLabel :: FastString - , siStdCallArgSize :: (Maybe Int) -- arg list size for std call mangling - , siIsIOCall :: Bool - , siReturnType :: String - , siArgTypes :: [String] + { siCWrapperLabel :: FastString + , siStdCallArgSize :: (Maybe Int) -- arg list size for std call mangling + , siIsIOCall :: Bool + , siReturnType :: String + , siArgTypes :: [String] } data StubDecl @@ -24,6 +30,6 @@ data StubDecl mergeForeignStubs :: [ForeignStubs] -> ForeignStubs mergeForeignStubs stubs = case [(h, c) | ForeignStubs h c <- stubs] of - [] -> NoStubs - l -> ForeignStubs h c where (h, c) = mconcat l + [] -> NoStubs + l -> ForeignStubs h c where (h, c) = mconcat l diff --git a/wpc-plugin/src/WPC/GhcStgApp.hs b/wpc-plugin/src/WPC/GhcStgApp.hs index f196d18..f9a436f 100644 --- a/wpc-plugin/src/WPC/GhcStgApp.hs +++ b/wpc-plugin/src/WPC/GhcStgApp.hs @@ -1,39 +1,43 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} module WPC.GhcStgApp where -import GHC.Prelude - -import GHC.Data.Maybe -import GHC.Platform.ArchOS -import GHC.Utils.Outputable -import GHC.Unit.Info -import GHC.Unit.Home.ModInfo -import GHC.Unit.Module.Deps -import GHC.Linker.Static.Utils -import GHC.Linker.Types -import GHC.Unit.Module.ModIface - -import GHC.Driver.Ppr -import GHC.Driver.Session - -import qualified GHC.Data.ShortText as ST - -import GHC.Utils.Json - -import Data.List ( isPrefixOf ) -import Data.Containers.ListUtils ( nubOrd ) -import qualified Data.Set as Set -import Data.Version -import GHC.Unit.State -import GHC.Unit.Env -import GHC.Unit.Types -import GHC.Platform - -import System.FilePath -import System.Directory - -import WPC.Yaml +import Control.Applicative (Applicative (..)) + +import Data.Bool (Bool (..), not, otherwise) +import Data.Containers.ListUtils (nubOrd) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor (Functor (..)) +import Data.List (isPrefixOf, (++)) +import qualified Data.Set as Set +import Data.String (String) +import Data.Version (showVersion) + +import GHC.Data.Maybe (Maybe (..), fromMaybe, maybe, maybeToList) +import qualified GHC.Data.ShortText as ST +import GHC.Driver.Ppr (showSDoc) +import GHC.Driver.Session (DynFlags (..), GeneralFlag (..), GhcNameVersion (..), Option (..), + PlatformMisc (..), gopt, objectSuf, ways) +import GHC.Linker.Static.Utils (exeFileName) +import GHC.Linker.Types (linkableObjs) +import GHC.Platform (Platform (..), platformOS) +import GHC.Platform.ArchOS (stringEncodeOS) +import GHC.Unit.Env (UnitEnv (..), preloadUnitsInfo', ue_unit_dbs) +import GHC.Unit.Home.ModInfo (HomeModInfo (..), HomeModLinkable (..), HomePackageTable, eltsHpt) +import GHC.Unit.Info (GenericUnitInfo (..)) +import GHC.Unit.Module.Deps (Dependencies (..)) +import GHC.Unit.Module.ModIface (ModIface_ (..)) +import GHC.Unit.State (UnitDatabase (..), mayThrowUnitErr) +import GHC.Unit.Types (GenModule (..), wiredInUnitIds) +import GHC.Utils.Json (JsonDoc (..)) +import GHC.Utils.Outputable (Outputable (..)) + +import System.Directory (getCurrentDirectory) +import System.FilePath (FilePath, isAbsolute, makeRelative, ()) +import System.IO (IO, putStrLn, writeFile) + +import Text.Show (Show (..)) + +import WPC.Yaml (renderYAML) {- TODO: @@ -60,43 +64,47 @@ writeGhcStgApp dflags unit_env hpt = do dep_unit_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) let pp :: Outputable a => a -> String pp = showSDoc dflags . ppr + + toAbsPath :: FilePath -> FilePath toAbsPath p | isAbsolute p = p | otherwise = root p - arrOfAbsPathST = arrOfAbsPath . map ST.unpack - arrOfAbsPath = JSArray . map JSString . nubOrd . map toAbsPath + + arrOfAbsPathST = arrOfAbsPath . fmap ST.unpack + arrOfAbsPath = JSArray . fmap JSString . nubOrd . fmap toAbsPath + app_deps = JSArray [ JSObject [ ("name", JSString $ pp unitPackageName) , ("version", JSString (showVersion unitPackageVersion)) , ("id", JSString $ pp unitId) , ("unit-import-dirs", arrOfAbsPathST unitImportDirs) - , ("unit-libraries", JSArray $ map (JSString . ST.unpack) unitLibraries) + , ("unit-libraries", JSArray $ fmap (JSString . ST.unpack) unitLibraries) , ("library-dirs", arrOfAbsPathST unitLibraryDirs) - , ("extra-libraries", JSArray $ map (JSString . ST.unpack) unitExtDepLibsSys) + , ("extra-libraries", JSArray $ fmap (JSString . ST.unpack) unitExtDepLibsSys) , ("framework-dirs", arrOfAbsPathST unitExtDepFrameworkDirs) - , ("extra-frameworks", JSArray $ map (JSString . ST.unpack) unitExtDepFrameworks) - , ("ld-options", JSArray $ map (JSString . ST.unpack) unitLinkerOptions) - , ("exposed-modules", JSArray $ map (JSString . pp) [mod | (mod, Nothing) <- unitExposedModules]) - , ("hidden-modules", JSArray $ map (JSString . pp) unitHiddenModules) - , ("depends", JSArray $ map (JSString . pp) unitDepends) + , ("extra-frameworks", JSArray $ fmap (JSString . ST.unpack) unitExtDepFrameworks) + , ("ld-options", JSArray $ fmap (JSString . ST.unpack) unitLinkerOptions) + , ("exposed-modules", JSArray $ fmap (JSString . pp) [mod' | (mod', Nothing) <- unitExposedModules]) + , ("hidden-modules", JSArray $ fmap (JSString . pp) unitHiddenModules) + , ("depends", JSArray $ fmap (JSString . pp) unitDepends) ] | GenericUnitInfo{..} <- dep_unit_infos ] - let arrOfStr = JSArray . map JSString . nubOrd - appLdOptions = [ o - | Option o <- ldInputs dflags - , not $ isPrefixOf "-l" o - ] - odir = fromMaybe "." (objectDir dflags) - mainModName = mainModuleNameIs dflags - mainModObjs = [ makeRelative odir o - | HomeModInfo{..} <- home_mod_infos - , mainModName == moduleName (mi_module hm_iface) - , l <- maybeToList $ homeMod_object hm_linkable - , o <- linkableObjs l - ] + let arrOfStr = JSArray . fmap JSString . nubOrd + appLdOptions = [ o + | Option o <- ldInputs dflags + , not $ isPrefixOf "-l" o + ] + odir = fromMaybe "." $ objectDir dflags + mainModName = mainModuleNameIs dflags + mainModObjs = [ makeRelative odir o + | HomeModInfo{..} <- home_mod_infos + , mainModName == moduleName (mi_module hm_iface) + , l <- maybeToList $ homeMod_object hm_linkable + , o <- linkableObjs l + ] mainModObj <- case mainModObjs of [o] -> pure $ JSString o l -> do @@ -109,20 +117,20 @@ writeGhcStgApp dflags unit_env hpt = do , ("platform-os", JSString . stringEncodeOS . platformOS $ targetPlatform dflags) , ("no-hs-main", JSBool $ gopt Opt_NoHsMain dflags) , ("o-suffix", JSString $ objectSuf dflags) - , ("ways", arrOfStr $ map show . Set.toList $ ways dflags) + , ("ways", arrOfStr $ fmap show . Set.toList $ ways dflags) , ("object-dir", JSString . toAbsPath $ fromMaybe root (objectDir dflags)) , ("app-unit-id", JSString . pp $ ue_current_unit unit_env) - , ("app-modules", JSArray $ map (JSString . pp) [moduleName . mi_module $ hm_iface | HomeModInfo{..} <- home_mod_infos]) + , ("app-modules", JSArray $ fmap (JSString . pp) [moduleName . mi_module $ hm_iface | HomeModInfo{..} <- home_mod_infos]) , ("app-main-module-name", JSString $ pp mainModName) , ("app-main-module-object", mainModObj) , ("extra-ld-inputs", arrOfAbsPath [f | FileOption _ f <- ldInputs dflags]) , ("library-dirs", arrOfAbsPath $ libraryPaths dflags) , ("extra-libraries", arrOfStr [lib | Option ('-':'l':lib) <- ldInputs dflags]) , ("framework-dirs", arrOfAbsPath $ frameworkPaths dflags) - , ("extra-frameworks", JSArray $ map JSString $ cmdlineFrameworks dflags) + , ("extra-frameworks", JSArray $ fmap JSString $ cmdlineFrameworks dflags) , ("ld-options", arrOfStr appLdOptions) - , ("unit-db-paths", arrOfAbsPath $ maybe [] (map unitDatabasePath) $ ue_unit_dbs unit_env) - , ("wired-in-unit-ids", JSArray $ map (JSString . pp) wiredInUnitIds) + , ("unit-db-paths", arrOfAbsPath $ maybe [] (fmap unitDatabasePath) $ ue_unit_dbs unit_env) + , ("wired-in-unit-ids", JSArray $ fmap (JSString . pp) wiredInUnitIds) , ("app-deps", app_deps) ] diff --git a/wpc-plugin/src/WPC/GlobalEnv.hs b/wpc-plugin/src/WPC/GlobalEnv.hs index 8e8f655..750072a 100644 --- a/wpc-plugin/src/WPC/GlobalEnv.hs +++ b/wpc-plugin/src/WPC/GlobalEnv.hs @@ -1,21 +1,24 @@ module WPC.GlobalEnv where -import Data.IORef -import System.IO.Unsafe +import Data.Function (($)) +import Data.IORef (IORef, newIORef) +import Data.Maybe (Maybe (..)) -import GHC.Plugins -import GHC.Stg.Syntax -import GHC.Types.ForeignStubs +import GHC.Plugins (HscEnv, ModGuts, ModSummary) +import GHC.Stg.Syntax (CgStgTopBinding) +import GHC.Types.ForeignStubs (ForeignStubs) -import WPC.ForeignStubDecls +import System.IO.Unsafe (unsafePerformIO) + +import WPC.ForeignStubDecls (StubDecl) data GlobalEnv = GlobalEnv - { geModSummary :: Maybe ModSummary - , geModGuts :: Maybe ModGuts - , geStgBinds :: Maybe [CgStgTopBinding] - , geHscEnv :: Maybe HscEnv - , geStubDecls :: Maybe [(ForeignStubs, StubDecl)] + { geModSummary :: Maybe ModSummary + , geModGuts :: Maybe ModGuts + , geStgBinds :: Maybe [CgStgTopBinding] + , geHscEnv :: Maybe HscEnv + , geStubDecls :: Maybe [(ForeignStubs, StubDecl)] } emptyGlobalEnv :: GlobalEnv diff --git a/wpc-plugin/src/WPC/Modpak.hs b/wpc-plugin/src/WPC/Modpak.hs index 1b2d8f4..404ae45 100644 --- a/wpc-plugin/src/WPC/Modpak.hs +++ b/wpc-plugin/src/WPC/Modpak.hs @@ -1,38 +1,48 @@ -{-# LANGUAGE BangPatterns #-} module WPC.Modpak where -import System.Directory -import System.FilePath -import Data.Maybe -import Data.Containers.ListUtils ( nubOrd ) +import Control.Applicative (Applicative (..)) +import Control.DeepSeq (force) --- for external stg -import qualified WPC.StgToExtStg as ExtStg -import qualified Data.ByteString.Lazy as BSL +import Data.Binary (encode) +import Data.Bool (Bool (..), otherwise) +import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 -import Data.Binary - --- for .modpak -import GHC.SysTools.Process -import qualified GHC.Data.EnumSet as EnumSet -import GHC.Types.ForeignStubs -import GHC.Stg.Syntax - -import GHC.Plugins -import GHC.Utils.TmpFs -import GHC.Core.Ppr ( pprCoreBindings ) -import GHC.Unit.Finder -import GHC.Driver.Config.Finder (initFinderOpts) - -import GHC.Iface.Load -import GHC.Iface.Make -import GHC.Iface.Tidy -import GHC.Driver.Config.Tidy -import Control.DeepSeq (force) - -import GHC.Prelude - -import WPC.ForeignStubDecls +import Data.Containers.ListUtils (nubOrd) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor (Functor (..)) +import Data.List (unlines, unwords, (++)) +import Data.Maybe (Maybe (..), fromJust, fromMaybe) + +import GHC.Core.Ppr (pprCoreBindings) +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.OsPath (unsafeDecodeUtf) +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Tidy (initTidyOpts) +import GHC.Err (error) +import GHC.Iface.Binary (CompressionIFace (..)) +import GHC.Iface.Load (writeIface) +import GHC.Iface.Make (mkFullIface, mkPartialIface) +import GHC.Iface.Tidy (tidyProgram) +import GHC.Plugins (CgGuts (..), CoreProgram, DynFlags (..), GenModule (..), GeneralFlag (..), + GhcNameVersion (..), HscEnv (..), ModGuts, ModLocation (..), ModSummary, + Module, NamePprCtx (..), Option (..), QualifyName (..), + alwaysPrintPromTick, gopt_set, mkDumpStyle, neverQualifyModules, + neverQualifyPackages, objectSuf, showSDoc, targetProfile, withPprStyle) +import GHC.Stg.Syntax (CgStgTopBinding, panicStgPprOpts, pprStgTopBindings) +import GHC.SysTools.Process (runSomething) +import GHC.Types.ForeignStubs (ForeignStubs) +import GHC.Unit.Finder (mkStubPaths) +import GHC.Utils.TmpFs (TempFileLifetime (..), newTempName) + +import System.Directory (copyFile, createDirectoryIfMissing, renameFile) +import System.FilePath (makeRelative, replaceExtension, takeDirectory, ()) +import System.IO (FilePath, IO, writeFile) + +import Text.Show (Show (..)) + +import WPC.ForeignStubDecls (ForeignStubDecls) +import qualified WPC.StgToExtStg as ExtStg outputModPak :: HscEnv @@ -54,18 +64,18 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls tmpfs = hsc_tmpfs hsc_env --- save stg --- - let stgBin = encode (ExtStg.cvtModule dflags "stg" modUnitId modName mSrcPath stg_binds foreign_stubs0 foreign_decls) - modName = moduleName this_mod - modUnitId = moduleUnit this_mod - mSrcPath = ml_hs_file location - - odir = fromMaybe "." (objectDir dflags) - modpak_output0 = replaceExtension (ml_hi_file location) (objectSuf dflags ++ "_modpak") - modpak_output = odir "extra-compilation-artifacts" "wpc-plugin" "modpaks" makeRelative odir modpak_output0 + let stgBin = encode (ExtStg.cvtModule dflags "stg" modUnitId modName mSrcPath stg_binds foreign_stubs0 foreign_decls) + modName = moduleName this_mod + modUnitId = moduleUnit this_mod + mSrcPath = ml_hs_file location + + odir = fromMaybe "." (objectDir dflags) + modpak_output0 = replaceExtension (ml_hi_file location) (objectSuf dflags ++ "_modpak") + modpak_output = odir "extra-compilation-artifacts" "wpc-plugin" "modpaks" makeRelative odir modpak_output0 createDirectoryIfMissing True (takeDirectory modpak_output) - let moddir_output0 = replaceExtension (ml_hi_file location) (objectSuf dflags) - let moddir_output = odir "extra-compilation-artifacts" "wpc-plugin" "hs-modules" makeRelative odir moddir_output0 + let moddir_output0 = replaceExtension (ml_hi_file location) (objectSuf dflags) + let moddir_output = odir "extra-compilation-artifacts" "wpc-plugin" "hs-modules" makeRelative odir moddir_output0 createDirectoryIfMissing True moddir_output -- stgbin @@ -94,11 +104,12 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls let (mod_guts, mod_summary) = fromMaybe (error "missing ModGuts for fullcore .hi") mb_mod_guts fullcoreHiFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule (objectSuf dflags ++ "_fullcore-hi") - writeFullCoreInterface hsc_env mod_guts mod_summary fullcoreHiFile + writeFullCoreInterface hsc_env mod_guts mod_summary fullcoreHiFile foreign_stubs0 -- module compilation info - let ppYamlList key l = unlines $ key : ["- " ++ x | x <- nubOrd $ map show l] + let ppYamlList key l = unlines $ key : ["- " ++ x | x <- nubOrd $ fmap show l] ppYamlSingle key v = unwords [key, show v] + infoFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule (objectSuf dflags ++ "_info") writeFile infoFile $ unlines [ ppYamlSingle "ghc_name:" (ghcNameVersion_programName $ ghcNameVersion dflags) @@ -133,11 +144,11 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls Just fn -> addToZip "module.hs" fn ) ++ (if has_stub_h - then addToZip "module_stub.h" (mkStubPaths (initFinderOpts dflags) modName location) + then addToZip "module_stub.h" $ unsafeDecodeUtf $ fromJust $ mkStubPaths (initFinderOpts dflags) modName location else [] ) ++ (case m_stub_c of - Nothing -> [] + Nothing -> [] Just fn -> addToZip "module_stub.c" fn ) @@ -155,10 +166,10 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls Nothing -> pure () Just fn -> copyToDir "module.hs" fn if has_stub_h - then copyToDir "module_stub.h" (mkStubPaths (initFinderOpts dflags) modName location) + then copyToDir "module_stub.h" $ unsafeDecodeUtf $ fromJust $ mkStubPaths (initFinderOpts dflags) modName location else pure () case m_stub_c of - Nothing -> pure () + Nothing -> pure () Just fn -> copyToDir "module_stub.c" fn {- -- compress @@ -171,8 +182,8 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls ] -} -writeFullCoreInterface :: HscEnv -> ModGuts -> ModSummary -> FilePath -> IO () -writeFullCoreInterface hscEnv0 mod_guts mod_summary output_name = do +writeFullCoreInterface :: HscEnv -> ModGuts -> ModSummary -> FilePath -> ForeignStubs -> IO () +writeFullCoreInterface hscEnv0 mod_guts mod_summary output_name foreign_stubs = do let logger = hsc_logger hscEnv0 dflags0 = hsc_dflags hscEnv0 -- HINT: export the whole module core IR @@ -186,9 +197,9 @@ writeFullCoreInterface hscEnv0 mod_guts mod_summary output_name = do {-# SCC "GHC.Driver.Main.mkPartialIface" #-} -- This `force` saves 2M residency in test T10370 -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hscEnv (cg_binds cg_guts) details mod_summary mod_guts) + force (mkPartialIface hscEnv (cg_binds cg_guts) details mod_summary [] mod_guts) -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. - final_iface <- mkFullIface hscEnv partial_iface Nothing Nothing - writeIface logger (targetProfile dflags) output_name final_iface + final_iface <- mkFullIface hscEnv partial_iface Nothing Nothing foreign_stubs [] + writeIface logger (targetProfile dflags) NormalCompression output_name final_iface diff --git a/wpc-plugin/src/WPC/Plugin.hs b/wpc-plugin/src/WPC/Plugin.hs index d9c8fc2..71ccbf4 100644 --- a/wpc-plugin/src/WPC/Plugin.hs +++ b/wpc-plugin/src/WPC/Plugin.hs @@ -1,48 +1,54 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} module WPC.Plugin (plugin) where -import System.Directory -import System.FilePath -import System.IO -import Data.IORef -import Data.Maybe +import Control.Applicative (Applicative (..)) +import Control.Monad (Functor (..), Monad (..)) -import GHC.Plugins -import GHC.Driver.Hooks -import GHC.Driver.Pipeline as Pipeline -import GHC.Driver.Pipeline.Phases -import GHC.Driver.Pipeline.Execute -import GHC.Unit.Module.Status -import qualified GHC.StgToCmm as StgToCmm ( codeGen ) -import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) -import GHC.StgToCmm.Config -import GHC.Types.IPE -import GHC.Stg.Syntax -import GHC.StgToCmm.Types (ModuleLFInfos) -import GHC.Types.CostCentre -import GHC.Types.HpcInfo -import qualified GHC.Data.Stream as Stream -import GHC.Data.Stream (Stream) -import GHC.Cmm -import GHC.Cmm.Info -import GHC.Utils.TmpFs -import GHC.Utils.Misc -import GHC.Unit.Home.ModInfo -import GHC.Driver.CodeOutput -import Language.Haskell.Syntax.Decls -import GHC.Types.ForeignCall +import Data.Bool (Bool (..), otherwise) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.IORef (modifyIORef, readIORef) +import Data.List ((++)) +import Data.Maybe (Maybe (..), fromJust, fromMaybe) +import Data.Tuple (fst) -import Control.Monad -import qualified Data.Map as Map +import GHC.Cmm (CmmGroup, CmmGroupSRTs, RawCmmGroup) +import GHC.Cmm.Info (cmmToRawCmm) +import qualified GHC.Data.Stream as Stream +import GHC.Driver.CodeOutput (outputForeignStubs) +import GHC.Driver.Hooks (Hooks (..)) +import GHC.Driver.Pipeline as Pipeline (TPhase (..), link, runPhase) +import GHC.Driver.Pipeline.Execute (runCcPhase) +import GHC.Driver.Pipeline.Phases (PhaseHook (..)) +import GHC.Plugins (CgGuts (..), CommandLineOption, CoreM, CoreToDo (..), DynFlags (..), + GhcLink, HscEnv (..), IsDoc (..), ModGuts (..), ModLocation (..), Module, + NamePprCtx (..), OccName, OutputableP (..), Plugin (..), QualifyName (..), + SuccessFlag, TyCon, alwaysPrintPromTick, blankLine, defaultPlugin, + hsc_units, liftIO, mkDumpStyle, neverQualifyModules, neverQualifyPackages, + objectSuf, showSDoc, targetProfile, withPprStyle) +import GHC.Stg.Syntax (CgStgTopBinding) +import qualified GHC.StgToCmm as StgToCmm (codeGen) +import GHC.StgToCmm.CgUtils (CgStream) +import GHC.StgToCmm.Config (StgToCmmConfig) +import GHC.StgToCmm.Types (ModuleLFInfos) +import GHC.Types.CostCentre (CollectedCCs) +import GHC.Types.IPE (InfoTableProvMap) +import GHC.Types.Unique.DSM (UniqDSMT) +import GHC.Unit.Home.ModInfo (HomePackageTable) +import GHC.Unit.Module.Status (HscBackendAction (..)) +import GHC.Utils.TmpFs (TempFileLifetime (..), newTempName) -import WPC.Modpak -import WPC.GhcStgApp -import WPC.Foreign -import WPC.Stubs -import WPC.GlobalEnv -import WPC.ForeignStubDecls +import System.Directory (copyFile, createDirectoryIfMissing) +import System.FilePath (makeRelative, replaceExtension, takeDirectory, ()) +import System.IO (Handle, IO, IOMode (..), hClose, hPutStr, openFile, putStrLn) + +import Text.Show (Show (..)) + +import WPC.Foreign (dsForeignsFun) +import WPC.ForeignStubDecls (ForeignStubDecls (..)) +import WPC.GhcStgApp (writeGhcStgApp) +import WPC.GlobalEnv (GlobalEnv (..), globalEnvIORef) +import WPC.Modpak (outputModPak) +import WPC.Stubs (outputCapiStubs) plugin :: Plugin plugin = defaultPlugin @@ -51,7 +57,7 @@ plugin = defaultPlugin } coreToDosFun :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -coreToDosFun cmdOpts todo0 = do +coreToDosFun _cmdOpts todo0 = do let captureCore :: ModGuts -> CoreM ModGuts captureCore mg = do --putMsgS $ "wpc-plugin captureCore pass" @@ -61,7 +67,7 @@ coreToDosFun cmdOpts todo0 = do todo = todo0 ++ [CoreDoPluginPass "capture IR" captureCore] --putMsgS $ "wpc-plugin coreToDosFun cmdOpts: " ++ show cmdOpts - --putMsg $ text "wpc-plugin coreToDosFun todo: " <+> vcat (map ppr todo) + --putMsg $ text "wpc-plugin coreToDosFun todo: " <+> vcat (fmap ppr todo) return todo driverFun :: [CommandLineOption] -> HscEnv -> IO HscEnv @@ -122,32 +128,32 @@ data TPhase res where runPhaseFun :: forall a . TPhase a -> IO a runPhaseFun phase = do let phaseStr = case phase of - T_Unlit{} -> "T_Unlit" - T_FileArgs{} -> "T_FileArgs" - T_Cpp{} -> "T_Cpp" - T_HsPp{} -> "T_HsPp" - T_HscRecomp{} -> "T_HscRecomp" - T_Hsc{} -> "T_Hsc" - T_HscPostTc{} -> "T_HscPostTc" - T_HscBackend{} -> "T_HscBackend" - T_CmmCpp{} -> "T_CmmCpp" - T_Cmm{} -> "T_Cmm" - T_Cc{} -> "T_Cc" - T_As{} -> "T_As" - T_Js{} -> "T_Js" - T_ForeignJs{} -> "T_ForeignJs" - T_LlvmOpt{} -> "T_LlvmOpt" - T_LlvmLlc{} -> "T_LlvmLlc" - T_LlvmAs{} -> "T_LlvmAs" - T_LlvmMangle{} -> "T_LlvmMangle" - T_MergeForeign{} -> "T_MergeForeign" + T_Unlit{} -> "T_Unlit" + T_FileArgs{} -> "T_FileArgs" + T_Cpp{} -> "T_Cpp" + T_HsPp{} -> "T_HsPp" + T_HscRecomp{} -> "T_HscRecomp" + T_Hsc{} -> "T_Hsc" + T_HscPostTc{} -> "T_HscPostTc" + T_HscBackend{} -> "T_HscBackend" + T_CmmCpp{} -> "T_CmmCpp" + T_Cmm{} -> "T_Cmm" + T_Cc{} -> "T_Cc" + T_As{} -> "T_As" + T_Js{} -> "T_Js" + T_ForeignJs{} -> "T_ForeignJs" + T_LlvmOpt{} -> "T_LlvmOpt" + T_LlvmLlc{} -> "T_LlvmLlc" + T_LlvmAs{} -> "T_LlvmAs" + T_LlvmMangle{} -> "T_LlvmMangle" + T_MergeForeign{} -> "T_MergeForeign" putStrLn $ " ###### wpc-plugin runPhaseFun phase: " ++ phaseStr --undefined case phase of - T_Cc phase pipe_env hsc_env location input_fn -> do - output_fn <- runCcPhase phase pipe_env hsc_env location input_fn + T_Cc phase' pipe_env hsc_env location input_fn -> do + output_fn <- runCcPhase phase' pipe_env hsc_env location input_fn putStrLn $ " ###### wpc-plugin runPhaseFun T_Cc input_fn: " ++ input_fn ++ " output_fn: " ++ output_fn let dflags = hsc_dflags hsc_env odir = fromMaybe "." (objectDir dflags) @@ -189,11 +195,11 @@ runPhaseFun phase = do GlobalEnv{..} <- readIORef globalEnvIORef --writeIORef globalEnvIORef (emptyModpakData {geHscEnv = Just hscEnv}) modifyIORef globalEnvIORef $ \d -> d {geHscEnv = Just hscEnv} - let CgGuts{..} = hscs_guts - Just (mg@ModGuts{..}) = geModGuts - Just ms = geModSummary - Just stgBinds = geStgBinds - Just stubDecls = geStubDecls + let CgGuts{..} = hscs_guts + (mg@ModGuts{..}) = fromJust $ geModGuts + ms = fromJust $ geModSummary + stgBinds = fromJust $ geStgBinds + stubDecls = fromJust $ geStubDecls ---------------- -- handle stubs @@ -213,14 +219,14 @@ runPhaseFun phase = do _ -> runPhase phase -stgToCmmFun :: HscEnv -> StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos -stgToCmmFun hscEnv cfg itpm tcList ccc stgBinds hpcInfo = do +stgToCmmFun :: HscEnv -> StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos +stgToCmmFun hscEnv cfg itpm tcList ccc stgBinds = do liftIO $ do putStrLn $ " ###### run stgToCmmFun" modifyIORef globalEnvIORef $ \d -> d {geStgBinds = Just stgBinds} - StgToCmm.codeGen (hsc_logger hscEnv) (hsc_tmpfs hscEnv) cfg itpm tcList ccc stgBinds hpcInfo + fmap fst $ StgToCmm.codeGen (hsc_logger hscEnv) (hsc_tmpfs hscEnv) cfg itpm tcList ccc stgBinds -cmmToRawCmmFun :: Handle -> HscEnv -> DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) +cmmToRawCmmFun ::forall a. Handle -> HscEnv -> DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a -> IO (CgStream RawCmmGroup a) cmmToRawCmmFun cmmHandle hscEnv dflags mMod cmms = do let logger = hsc_logger hscEnv profile = targetProfile dflags @@ -228,7 +234,8 @@ cmmToRawCmmFun cmmHandle hscEnv dflags mMod cmms = do rawcmms0 <- cmmToRawCmm logger profile cmms -- name pretty printer setup - let qualifyImportedNames mod _ + let qualifyImportedNames :: Module -> OccName -> QualifyName + qualifyImportedNames mod _ | Just mod == mMod = NameUnqual | otherwise = NameNotInScope1 print_unqual = QueryQualify qualifyImportedNames @@ -237,21 +244,23 @@ cmmToRawCmmFun cmmHandle hscEnv dflags mMod cmms = do alwaysPrintPromTick dumpStyle = mkDumpStyle print_unqual - let dump a = do - let cmmDoc = vcat $ map (\i -> pdoc platform i $$ blankLine) a - hPutStr cmmHandle . showSDoc dflags $ withPprStyle dumpStyle cmmDoc + let dump :: RawCmmGroup -> UniqDSMT IO RawCmmGroup + dump a = do + let cmmDoc = vcat $ fmap (\i -> pdoc platform i $$ blankLine) a + liftIO $ hPutStr cmmHandle . showSDoc dflags $ withPprStyle dumpStyle cmmDoc pure a + pure $ Stream.mapM dump rawcmms0 linkFun :: GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag linkFun ghcLink dflags isBatchMode hpt = do putStrLn " ###### linkFun" GlobalEnv{..} <- readIORef globalEnvIORef - let Just HscEnv{..} = geHscEnv + let HscEnv{..} = fromJust $ geHscEnv hooks = hsc_hooks {linkHook = Nothing} result <- Pipeline.link ghcLink hsc_logger hsc_tmpfs hsc_FC hooks dflags hsc_unit_env isBatchMode Nothing hpt {- - IDEA: generate ghcstgapp file along with modpak file for the main module + IDEA: generate ghc_stgapp file along with modpak file for the main module do not use the link hook this will make the plugin work for 'ghc -c' + 'ghc Main.o -o ExeName' use cases OR diff --git a/wpc-plugin/src/WPC/StgToExtStg.hs b/wpc-plugin/src/WPC/StgToExtStg.hs index 457b303..c03e2cb 100644 --- a/wpc-plugin/src/WPC/StgToExtStg.hs +++ b/wpc-plugin/src/WPC/StgToExtStg.hs @@ -1,60 +1,81 @@ -{-# LANGUAGE ImplicitParams, RecordWildCards, LambdaCase, MultiWayIf, TupleSections, OverloadedStrings #-} -module WPC.StgToExtStg where - -import Stg.Syntax +{-# OPTIONS_GHC -Wno-orphans #-} -import GHC.Prelude +module WPC.StgToExtStg where -import qualified Data.ByteString.Char8 as BS8 +import Control.Applicative (Applicative (..)) +import Control.Exception (SomeException, catch, evaluate, throw, throwIO) +import Control.Monad (forM_, mapM, sequence, when) +import Control.Monad.State.Strict (MonadState (..), State, gets, modify', runState) + +import Data.Bool (not, otherwise, (||)) +import qualified Data.ByteString.Char8 as BS8 +import Data.Eq (Eq (..)) +import Data.Function (id, ($), (.)) +import Data.Functor (Functor (..), (<$>)) +import Data.Int (Int) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List (concatMap, isInfixOf, null, unwords, (++)) +import qualified Data.Map as Map +import Data.Maybe (Maybe (..), catMaybes) +import Data.Ord (Ord) +import qualified Data.Set as Set +import Data.String (String) +import Data.Tuple (fst) import qualified GHC -import qualified GHC.Hs.Extension as GHC -import qualified GHC.Hs.Decls as GHC -import qualified GHC.Builtin.PrimOps as GHC -import qualified GHC.Core as GHC -import qualified GHC.Core.DataCon as GHC -import qualified GHC.Core.TyCon as GHC -import qualified GHC.Core.TyCo.Ppr as GHC -import qualified GHC.Core.TyCo.Rep as GHC -import qualified GHC.Core.Type as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Driver.Ppr as GHC -import qualified GHC.Stg.Syntax as GHC -import qualified GHC.Cmm.CLabel as GHC -import qualified GHC.Types.Basic as GHC -import qualified GHC.Types.ForeignCall as GHC -import qualified GHC.Types.Id as GHC -import qualified GHC.Types.Id.Info as GHC -import qualified GHC.Types.Literal as GHC -import qualified GHC.Types.Name as GHC -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Types.RepType as GHC -import qualified GHC.Types.Unique as GHC -import qualified GHC.Types.Tickish as GHC -import qualified GHC.Types.SourceText as GHC -import qualified GHC.Types.ForeignStubs as GHC ---import qualified GHC.Utils.Panic.Plain as GHC -import qualified GHC.Unit.Types as GHC ---import qualified GHC.Unit.Module.Name as GHC -import qualified GHC.Utils.Outputable as GHC -import qualified GHC.Data.Strict as GHC -import Control.Monad -import Control.Monad.State.Strict -import Data.IntSet (IntSet) -import Data.IntMap (IntMap) -import Data.Maybe -import Data.List -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Debug.Trace -import Control.Exception -import System.IO.Unsafe - -import qualified WPC.ForeignStubDecls as WPC +import qualified GHC.Builtin.PrimOps as GHC +import qualified GHC.Core as GHC +import qualified GHC.Core.DataCon as GHC +import qualified GHC.Core.TyCo.Ppr as GHC +import qualified GHC.Core.TyCo.Rep as GHC +import qualified GHC.Core.TyCon as GHC +import qualified GHC.Core.Type as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Data.Strict as GHC +import qualified GHC.Driver.Ppr as GHC +import GHC.Err (error) +import GHC.Real (fromIntegral) +import qualified GHC.Stg.Syntax as GHC +import qualified GHC.Types.Basic as GHC +import qualified GHC.Types.ForeignCall as GHC +import qualified GHC.Types.ForeignStubs as GHC +import qualified GHC.Types.Id as GHC +import qualified GHC.Types.Id.Info as GHC +import qualified GHC.Types.Literal as GHC +import qualified GHC.Types.Name as GHC +import qualified GHC.Types.RepType as GHC +import qualified GHC.Types.SourceText as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Types.Tickish as GHC +import qualified GHC.Types.Unique as GHC +import qualified GHC.Unit.Types as GHC +import qualified GHC.Utils.Outputable as GHC + +import Prelude (seq) + +import Stg.Syntax (Alt' (..), AltCon' (..), AltType' (..), Arg' (..), BinderId (..), + Binding' (..), BufSpan (..), CCallConv (..), CCallTarget (..), + CExportSpec (..), CImportSpec (..), CbvMark (..), DataConId (..), + DataConRep (..), Expr' (..), ForeignCall (..), ForeignExport (..), + ForeignImport (..), ForeignStubs' (..), Header (..), IdDetails (..), + LabelSpec (..), Lit (..), LitNumType (..), Module' (..), ModuleName (..), + Name, PrimCall (..), PrimElemRep (..), PrimRep (..), RealSrcSpan (..), + Rhs' (..), SAlt, SAltCon, SAltType, SArg, SBinder (..), SBinding, + SDataCon (..), SExpr, SForeignStubs, SModule, SRhs, SStubDecl, STopBinding, + STyCon (..), Safety (..), Scope (..), SourceText (..), SrcSpan (..), + StgOp (..), StubDecl' (..), StubImpl (..), Tickish (..), TopBinding' (..), + TyConId (..), Type (..), UnhelpfulSpanReason (..), Unique (..), + UnitId (..), UpdateFlag (..)) + +import System.IO (FilePath, IO, putStrLn) +import System.IO.Unsafe (unsafePerformIO) + +import Text.Show (Show (..)) + +import qualified WPC.ForeignStubDecls as WPC --trace :: String -> a -> a --trace _ = id @@ -63,13 +84,13 @@ import qualified WPC.ForeignStubDecls as WPC data Env = Env - { envExternalIds :: IntMap GHC.Id - , envTyCons :: IntMap GHC.TyCon + { envExternalIds :: IntMap GHC.Id + , envTyCons :: IntMap GHC.TyCon -- debug state - , envDefinedUnique :: IntSet + , envDefinedUnique :: IntSet - , envNameSrcLoc :: IntMap GHC.SrcSpan + , envNameSrcLoc :: IntMap GHC.SrcSpan } emptyEnv :: Env @@ -87,13 +108,19 @@ data ImplicitEnv type M = State Env + -- debug -checkName :: (?ienv :: ImplicitEnv) => GHC.Name -> M () +checkName + :: (?ienv :: ImplicitEnv) + => GHC.Name + -> M () checkName n = do let key = uniqueKey n loc = GHC.nameSrcSpan n - lastLoc <- state $ \env@Env{..} -> (IntMap.lookup key envNameSrcLoc, env {envNameSrcLoc = IntMap.insert key loc envNameSrcLoc}) + lastLoc <- state $ + \env@Env{..} -> + (IntMap.lookup key envNameSrcLoc, env {envNameSrcLoc = IntMap.insert key loc envNameSrcLoc}) case lastLoc of Nothing -> pure () Just l -> when (l == loc) $ do @@ -102,7 +129,9 @@ checkName n = do defKey :: (GHC.Uniquable a, GHC.Outputable a, ?ienv :: ImplicitEnv) => a -> M () defKey a = do let key = uniqueKey a - wasDefined <- state $ \env@Env{..} -> (IntSet.member key envDefinedUnique, env {envDefinedUnique = IntSet.insert key envDefinedUnique}) + wasDefined <- state $ + \env@Env{envDefinedUnique} -> + (IntSet.member key envDefinedUnique, env {envDefinedUnique = IntSet.insert key envDefinedUnique}) when wasDefined $ do error $ "redefinition of: " ++ ppr a @@ -136,7 +165,8 @@ cvtModuleName :: GHC.ModuleName -> ModuleName cvtModuleName = ModuleName . GHC.bytesFS . GHC.moduleNameFS cvtUnitIdAndModuleName :: GHC.Module -> (UnitId, ModuleName) -cvtUnitIdAndModuleName m = (cvtUnitId $ GHC.moduleUnit m, cvtModuleName $ GHC.moduleName m) +cvtUnitIdAndModuleName m = + (cvtUnitId $ GHC.moduleUnit m, cvtModuleName $ GHC.moduleName m) -- source location conversion @@ -160,8 +190,11 @@ cvtStrictMaybe = \case cvtSrcSpan :: GHC.SrcSpan -> SrcSpan cvtSrcSpan = \case - GHC.RealSrcSpan s mb -> RealSrcSpan (cvtRealSrcSpan s) (fmap cvtBufSpan $ cvtStrictMaybe mb) - GHC.UnhelpfulSpan r -> UnhelpfulSpan $ cvtUnhelpfulSpanReason r + GHC.RealSrcSpan s mb -> + RealSrcSpan + (cvtRealSrcSpan s) + (fmap cvtBufSpan $ cvtStrictMaybe mb) + GHC.UnhelpfulSpan r -> UnhelpfulSpan $ cvtUnhelpfulSpanReason r cvtUnhelpfulSpanReason :: GHC.UnhelpfulSpanReason -> UnhelpfulSpanReason cvtUnhelpfulSpanReason = \case @@ -180,7 +213,10 @@ cvtTickish = \case GHC.ProfNote{} -> ProfNote GHC.HpcTick{} -> HpcTick GHC.Breakpoint{} -> Breakpoint - GHC.SourceNote{..} -> SourceNote (cvtRealSrcSpan sourceSpan) (cvtLexicalFastString sourceName) + GHC.SourceNote{..} -> + SourceNote + (cvtRealSrcSpan sourceSpan) + (cvtLexicalFastString sourceName) -- data con conversion @@ -218,18 +254,34 @@ cvtDataTyConId tc instance GHC.Outputable Type where ppr = GHC.text . show -trpp :: (GHC.Outputable o, GHC.Outputable a, ?ienv :: ImplicitEnv) => String -> (o -> a) -> o -> a +{- +trpp + :: (GHC.Outputable o, GHC.Outputable a, ?ienv :: ImplicitEnv) + => String -> (o -> a) -> o -> a trpp msg f a = trace (unwords [msg, ":"]) $ trace ('\t' : ppr a) $ trace (unwords ["\t\t=", ppr (f a), "\n-----------\n"]) $ f a +-} {-# INLINE debugCvtAppType #-} -debugCvtAppType :: (?ienv :: ImplicitEnv) => GHC.Id -> [GHC.StgArg] -> GHC.Type -> String -> Type +debugCvtAppType + :: (?ienv :: ImplicitEnv) + => GHC.Id + -> [GHC.StgArg] + -> GHC.Type + -> String + -> Type debugCvtAppType f args ty msg = unsafePerformIO $ debugCvtAppTypeM f args ty msg {-# INLINE debugCvtAppTypeM #-} -debugCvtAppTypeM :: (?ienv :: ImplicitEnv) => GHC.Id -> [GHC.StgArg] -> GHC.Type -> String -> IO Type +debugCvtAppTypeM + :: (?ienv :: ImplicitEnv) + => GHC.Id + -> [GHC.StgArg] + -> GHC.Type + -> String + -> IO Type debugCvtAppTypeM f args ty msg = catch (let t = cvtTypeNormal ty in seq t (pure t)) $ \ex -> do putStrLn $ "cought exception during StgApp result type conversion" putStrLn "Normal:" @@ -247,8 +299,10 @@ debugCvtAppTypeM f args ty msg = catch (let t = cvtTypeNormal ty in seq t (pure putStrLn $ " " ++ ppr f ++ " :: " ++ showSDoc (GHC.debugPprType $ GHC.idType f) putStrLn "args:" forM_ args $ \a -> case a of - GHC.StgVarArg o -> putStrLn $ " " ++ ppr o ++ " :: " ++ showSDoc (GHC.debugPprType $ GHC.idType o) - GHC.StgLitArg l -> putStrLn $ " " ++ ppr l ++ " :: " ++ showSDoc (GHC.debugPprType $ GHC.literalType l) + GHC.StgVarArg o -> + putStrLn $ " " ++ ppr o ++ " :: " ++ showSDoc (GHC.debugPprType $ GHC.idType o) + GHC.StgLitArg l -> + putStrLn $ " " ++ ppr l ++ " :: " ++ showSDoc (GHC.debugPprType $ GHC.literalType l) putStrLn $ "function result type:" putStrLn $ " " ++ showSDoc (GHC.debugPprType ty) putStrLn $ "StgApp type label:" @@ -303,7 +357,7 @@ cvtTypeNormal t = PolymorphicRep | GHC.isUnboxedSumType t || GHC.isUnboxedTupleType t - = UnboxedTuple (map cvtPrimRep $ GHC.typePrimRep t) + = UnboxedTuple (fmap cvtPrimRep $ GHC.typePrimRep t) | [rep] <- GHC.typePrimRep t = SingleValue (cvtPrimRep rep) @@ -377,7 +431,7 @@ cvtLit = \case GHC.LitNullAddr -> LitNullAddr GHC.LitFloat x -> LitFloat x GHC.LitDouble x -> LitDouble x - GHC.LitLabel x i d -> LitLabel (GHC.bytesFS x) (cvtLabelSpec i d) + GHC.LitLabel x d -> LitLabel (GHC.bytesFS x) (cvtLabelSpec Nothing d) -- todo: maybe need fix GHC.LitNumber t i -> LitNumber (cvtLitNumType t) i r@GHC.LitRubbish{} -> LitRubbish (cvtType "LitRubbish" $ GHC.literalType r) @@ -414,16 +468,16 @@ cvtIdDetails i = case GHC.idDetails i of GHC.TickBoxOpId{} -> pure TickBoxOpId GHC.DFunId{} -> pure DFunId GHC.CoVarId{} -> pure CoVarId - GHC.JoinId ar m -> pure $ JoinId ar (fmap (map cvtCbvMark) m) - GHC.WorkerLikeId l -> pure $ WorkerLikeId $ map cvtCbvMark l + GHC.JoinId ar m -> pure $ JoinId ar (fmap (fmap cvtCbvMark) m) + GHC.WorkerLikeId l -> pure $ WorkerLikeId $ fmap cvtCbvMark l -cvtScope :: (?ienv :: ImplicitEnv) => GHC.Id -> Scope +cvtScope :: GHC.Id -> Scope cvtScope i | GHC.isExportedId i = ModulePublic | otherwise = ClosurePrivate cvtBinderIdClosureParam :: (?ienv :: ImplicitEnv) => IdDetails -> String -> GHC.Id -> SBinder -cvtBinderIdClosureParam details msg v +cvtBinderIdClosureParam details _msg v | GHC.isId v = SBinder { sbinderName = cvtOccName $ GHC.getOccName v , sbinderId = BinderId . cvtUnique . GHC.idUnique $ v @@ -468,13 +522,18 @@ cvtBinderIdM msg i = do cvtSourceText :: GHC.SourceText -> SourceText cvtSourceText = \case - GHC.SourceText s -> SourceText (GHC.bytesFS s) - GHC.NoSourceText -> NoSourceText + GHC.SourceText s -> SourceText (GHC.bytesFS s) + GHC.NoSourceText -> NoSourceText cvtCCallTarget :: GHC.CCallTarget -> CCallTarget cvtCCallTarget = \case - GHC.StaticTarget s l u b -> StaticTarget (cvtSourceText s) (GHC.bytesFS l) (fmap cvtUnitId u) b - GHC.DynamicTarget -> DynamicTarget + GHC.StaticTarget s l u b -> + StaticTarget + (cvtSourceText s) + (GHC.bytesFS l) + (fmap cvtUnitId u) + b + GHC.DynamicTarget -> DynamicTarget cvtCCallConv :: GHC.CCallConv -> CCallConv cvtCCallConv = \case @@ -491,10 +550,12 @@ cvtSafety = \case GHC.PlayRisky -> PlayRisky cvtForeignCall :: GHC.ForeignCall -> ForeignCall -cvtForeignCall (GHC.CCall (GHC.CCallSpec t c s)) = ForeignCall (cvtCCallTarget t) (cvtCCallConv c) (cvtSafety s) +cvtForeignCall (GHC.CCall (GHC.CCallSpec t c s)) = + ForeignCall (cvtCCallTarget t) (cvtCCallConv c) (cvtSafety s) cvtPrimCall :: GHC.PrimCall -> PrimCall -cvtPrimCall (GHC.PrimCall lbl uid) = PrimCall (GHC.bytesFS lbl) (cvtUnitId uid) +cvtPrimCall (GHC.PrimCall lbl uid) = + PrimCall (GHC.bytesFS lbl) (cvtUnitId uid) cvtOp :: GHC.StgOp -> StgOp cvtOp = \case @@ -519,7 +580,8 @@ cvtAltType = \case GHC.AlgAlt tc -> AlgAlt <$> cvtDataTyConId tc cvtAlt :: (?ienv :: ImplicitEnv) => GHC.CgStgAlt -> M SAlt -cvtAlt (GHC.GenStgAlt con bs e) = Alt <$> cvtAltCon con <*> mapM (cvtBinderIdM "Alt") bs <*> cvtExpr e +cvtAlt (GHC.GenStgAlt con bs e) = + Alt <$> cvtAltCon con <*> mapM (cvtBinderIdM "Alt") bs <*> cvtExpr e cvtAltCon :: (?ienv :: ImplicitEnv) => GHC.AltCon -> M SAltCon cvtAltCon = \case @@ -531,18 +593,20 @@ cvtAltCon = \case -- WORKAROUND for rewriteRhs in compiler/GHC/Stg/InferTags/Rewrite.hs cvtConAppTypeArgs :: (?ienv :: ImplicitEnv) => [GHC.Type] -> M [Type] -cvtConAppTypeArgs tys = pure . unsafePerformIO $ catch (evaluate $ map (cvtType "cvtConAppTypeArgs") tys) $ \case - GHC.Panic msg - | "mkSeqs shouldn't use the type arg" `isInfixOf` msg - -> pure [] - e -> throw e - -cvtConAppTypeArgs2 :: (?ienv :: ImplicitEnv) => [[GHC.PrimRep]] -> M [Type] -cvtConAppTypeArgs2 tys = pure . unsafePerformIO $ catch (evaluate [UnboxedTuple $ map cvtPrimRep l | l <- tys]) $ \case - GHC.Panic msg - | "mkSeqs shouldn't use the type arg" `isInfixOf` msg - -> pure [] - e -> throw e +cvtConAppTypeArgs tys = + pure . unsafePerformIO $ catch (evaluate $ fmap (cvtType "cvtConAppTypeArgs") tys) $ \case + GHC.Panic msg + | "mkSeqs shouldn't use the type arg" `isInfixOf` msg + -> pure [] + e -> throw e + +cvtConAppTypeArgs2 :: [[GHC.PrimRep]] -> M [Type] +cvtConAppTypeArgs2 tys = + pure . unsafePerformIO $ catch (evaluate [UnboxedTuple $ fmap cvtPrimRep l | l <- tys]) $ \case + GHC.Panic msg + | "mkSeqs shouldn't use the type arg" `isInfixOf` msg + -> pure [] + e -> throw e cvtExpr :: (?ienv :: ImplicitEnv) => GHC.CgStgExpr -> M SExpr cvtExpr = \case @@ -554,7 +618,6 @@ cvtExpr = \case GHC.StgLet _ b e -> StgLet <$> cvtBind b <*> cvtExpr e GHC.StgLetNoEscape _ b e -> StgLetNoEscape <$> cvtBind b <*> cvtExpr e GHC.StgTick t e -> StgTick (cvtTickish t) <$> cvtExpr e - e -> error $ "invalid stg expression: " ++ ppr (GHC.pprStgExpr GHC.panicStgPprOpts e) -- stg rhs conversion (heap objects) @@ -563,11 +626,18 @@ cvtUpdateFlag = \case GHC.ReEntrant -> ReEntrant GHC.Updatable -> Updatable GHC.SingleEntry -> SingleEntry + GHC.JumpedTo -> JumpedTo cvtRhs :: (?ienv :: ImplicitEnv) => GHC.CgStgRhs -> M SRhs cvtRhs = \case - GHC.StgRhsClosure _ _ u bs e _ -> StgRhsClosure [] (cvtUpdateFlag u) <$> mapM (cvtBinderIdClosureParamM "StgRhsClosure") bs <*> cvtExpr e - GHC.StgRhsCon _ dc _ _ args _ -> StgRhsCon <$> cvtDataCon dc <*> mapM cvtArg args + GHC.StgRhsClosure _ _ u bs e _ -> + StgRhsClosure [] (cvtUpdateFlag u) + <$> mapM (cvtBinderIdClosureParamM "StgRhsClosure") bs + <*> cvtExpr e + GHC.StgRhsCon _ dc _ _ args _ -> + StgRhsCon + <$> cvtDataCon dc + <*> mapM cvtArg args -- bind and top-bind conversion @@ -581,13 +651,18 @@ cvtTopBind = \case GHC.StgTopLifted b -> StgTopLifted <$> cvtBind b GHC.StgTopStringLit b bs -> StgTopStringLit <$> cvtBinderIdM "StgTopStringLit" b <*> pure bs -cvtTopBindsAndStubs :: (?ienv :: ImplicitEnv) => [GHC.CgStgTopBinding] -> GHC.ForeignStubs -> WPC.ForeignStubDecls -> M ([STopBinding], SForeignStubs, [(UnitId, [(ModuleName, [SBinder])])]) +cvtTopBindsAndStubs + :: (?ienv :: ImplicitEnv) + => [GHC.CgStgTopBinding] + -> GHC.ForeignStubs + -> WPC.ForeignStubDecls + -> M ([STopBinding], SForeignStubs, [(UnitId, [(ModuleName, [SBinder])])]) cvtTopBindsAndStubs binds stubs decls = do b <- mapM cvtTopBind binds s <- cvtForeignStubs stubs decls let stgTopIds = concatMap topBindIds binds - topKeys = IntSet.fromList $ map uniqueKey stgTopIds + topKeys = IntSet.fromList $ fmap uniqueKey stgTopIds Env{..} <- get extItems <- sequence [mkExternalName e | (k,e) <- IntMap.toList envExternalIds, IntSet.notMember k topKeys] pure (b, s, groupByUnitIdAndModule extItems) @@ -604,33 +679,45 @@ cvtCImportSpec = \case GHC.CWrapper -> CWrapper cvtCExportSpec :: GHC.CExportSpec -> CExportSpec -cvtCExportSpec (GHC.CExportStatic t n cc) = CExportStatic (cvtSourceText t) (GHC.bytesFS n) (cvtCCallConv cc) +cvtCExportSpec (GHC.CExportStatic t n cc) = + CExportStatic (cvtSourceText t) (GHC.bytesFS n) (cvtCCallConv cc) -cvtStubImpl :: (?ienv :: ImplicitEnv) => WPC.StubImpl -> StubImpl +cvtStubImpl :: WPC.StubImpl -> StubImpl cvtStubImpl = \case - WPC.StubImplImportCWrapper n m b r a -> StubImplImportCWrapper (GHC.bytesFS n) m b (BS8.pack r) (map BS8.pack a) + WPC.StubImplImportCWrapper n m b r a -> + StubImplImportCWrapper (GHC.bytesFS n) m b (BS8.pack r) (fmap BS8.pack a) cvtForeignImport :: GHC.ForeignImport GHC.GhcTc -> ForeignImport -cvtForeignImport (GHC.CImport t cc s m is) = CImport (cvtCCallConv $ GHC.unLoc cc) (cvtSafety $ GHC.unLoc s) (fmap cvtHeader m) (cvtCImportSpec is) (cvtSourceText $ GHC.unLoc t) +cvtForeignImport (GHC.CImport t cc s m is) = + CImport + (cvtCCallConv $ GHC.unLoc cc) + (cvtSafety $ GHC.unLoc s) + (fmap cvtHeader m) + (cvtCImportSpec is) + (cvtSourceText $ GHC.unLoc t) cvtForeignExport :: GHC.ForeignExport GHC.GhcTc -> ForeignExport cvtForeignExport (GHC.CExport t s) = CExport (cvtCExportSpec $ GHC.unLoc s) (cvtSourceText $ GHC.unLoc t) -cvtStubDecl :: (?ienv :: ImplicitEnv) => WPC.StubDecl -> M SStubDecl +cvtStubDecl :: WPC.StubDecl -> M SStubDecl cvtStubDecl = \case WPC.StubDeclImport fi m -> pure $ StubDeclImport (cvtForeignImport fi) (fmap cvtStubImpl m) WPC.StubDeclExport fe idOcc -> StubDeclExport (cvtForeignExport fe) <$> cvtOccId idOcc <*> pure (BS8.pack "") -- TODO: remove this -cvtForeignStubs :: (?ienv :: ImplicitEnv) => GHC.ForeignStubs -> WPC.ForeignStubDecls -> M SForeignStubs +cvtForeignStubs + :: (?ienv :: ImplicitEnv) + => GHC.ForeignStubs + -> WPC.ForeignStubDecls + -> M SForeignStubs cvtForeignStubs stubs (WPC.ForeignStubDecls decls) = case stubs of GHC.NoStubs -> pure NoStubs - GHC.ForeignStubs (GHC.CHeader h) (GHC.CStub c iList fList) + GHC.ForeignStubs (GHC.CHeader h) (GHC.CStub c _iList _fList) -> ForeignStubs (bs8SDoc $ GHC.pprCode h) (bs8SDoc $ GHC.pprCode c) - [] -- TODO: (map cvtModuleCLabel iList) - [] -- TODO: (map cvtModuleCLabel fList) + [] -- TODO: (fmap cvtModuleCLabel iList) + [] -- TODO: (fmap cvtModuleCLabel fList) <$> mapM cvtStubDecl [d | (_, d) <- decls] {- cvtModuleLabelKind :: GHC.ModuleLabelKind -> ModuleLabelKind @@ -649,20 +736,38 @@ cvtModuleCLabel clbl = case GHC.deconstructModuleLabel_maybe clbl of -- module conversion -cvtModule :: GHC.DynFlags -> String -> GHC.Unit -> GHC.ModuleName -> Maybe FilePath -> [GHC.CgStgTopBinding] -> GHC.ForeignStubs -> WPC.ForeignStubDecls -> SModule +cvtModule + :: GHC.DynFlags + -> String + -> GHC.Unit + -> GHC.ModuleName + -> Maybe FilePath + -> [GHC.CgStgTopBinding] + -> GHC.ForeignStubs + -> WPC.ForeignStubDecls + -> SModule cvtModule dflags phase unit' modName' mSrcPath binds foreignStubs foreignDecls = let ?ienv = ImplicitEnv dflags in cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls -cvtModule' :: (?ienv :: ImplicitEnv) => String -> GHC.Unit -> GHC.ModuleName -> Maybe FilePath -> [GHC.CgStgTopBinding] -> GHC.ForeignStubs -> WPC.ForeignStubDecls -> SModule -cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls@(WPC.ForeignStubDecls fDecls) = +cvtModule' + :: (?ienv :: ImplicitEnv) + => String + -> GHC.Unit + -> GHC.ModuleName + -> Maybe FilePath + -> [GHC.CgStgTopBinding] + -> GHC.ForeignStubs + -> WPC.ForeignStubDecls + -> SModule +cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls = Module { modulePhase = BS8.pack phase , moduleUnitId = unitId , moduleName = modName , moduleSourceFilePath = fmap BS8.pack mSrcPath , moduleForeignStubs = stubs - , moduleHasForeignExported = not $ null [id | (_, WPC.StubDeclExport _ id) <- fDecls] + , moduleHasForeignExported = not $ null [id' | (_, WPC.StubDeclExport _ id') <- fDecls] , moduleDependency = dependencies , moduleExternalTopIds = externalIds , moduleTyCons = tyCons @@ -671,15 +776,26 @@ cvtModule' phase unit' modName' mSrcPath binds foreignStubs foreignDecls@(WPC.Fo ((topBinds, stubs, externalIds), Env{..}) = runState (cvtTopBindsAndStubs binds foreignStubs foreignDecls) initialEnv - initialEnv = emptyEnv - stgTopIds = concatMap topBindIds binds - modName = cvtModuleName modName' - unitId = cvtUnitId unit' - tyCons = groupByUnitIdAndModule . map mkTyCon $ IntMap.elems envTyCons + initialEnv = emptyEnv + _stgTopIds = concatMap topBindIds binds + modName = cvtModuleName modName' + unitId = cvtUnitId unit' + tyCons = groupByUnitIdAndModule . fmap mkTyCon $ IntMap.elems envTyCons + + WPC.ForeignStubDecls fDecls = foreignDecls -- calculate dependencies - externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ map (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] - dependencies = map (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons + externalTyCons = + [ (cvtUnitIdAndModuleName m, ()) + | m <- catMaybes $ fmap (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons + ] + dependencies = + fmap (fmap (fmap fst)) $ + groupByUnitIdAndModule $ + [ ((u, m), ()) + | (u, ml) <- externalIds + , (m, _) <- ml + ] ++ externalTyCons -- utils @@ -690,7 +806,8 @@ groupByUnitIdAndModule l = [Map.singleton u (Map.singleton m (Set.singleton b)) | ((u, m), b) <- l] mkExternalName :: (?ienv :: ImplicitEnv) => GHC.Id -> M ((UnitId, ModuleName), SBinder) -mkExternalName x = (cvtUnitIdAndModuleName . GHC.nameModule $ GHC.getName x,) <$> cvtBinderIdM "mkExternalName" x +mkExternalName x = + (cvtUnitIdAndModuleName . GHC.nameModule $ GHC.getName x,) <$> cvtBinderIdM "mkExternalName" x mkTyCon :: (?ienv :: ImplicitEnv) => GHC.TyCon -> ((UnitId, ModuleName), STyCon) mkTyCon tc = (cvtUnitIdAndModuleName $ GHC.nameModule n, b) where @@ -698,7 +815,7 @@ mkTyCon tc = (cvtUnitIdAndModuleName $ GHC.nameModule n, b) where b = STyCon { stcName = cvtOccName $ GHC.getOccName n , stcId = TyConId . cvtUnique . GHC.getUnique $ n - , stcDataCons = map mkSDataCon . sortDataCons $ GHC.tyConDataCons tc + , stcDataCons = fmap mkSDataCon . sortDataCons $ GHC.tyConDataCons tc , stcDefLoc = cvtSrcSpan $ GHC.nameSrcSpan n } sortDataCons l = IntMap.elems $ IntMap.fromList [(GHC.dataConTag dc, dc) | dc <- l] @@ -710,10 +827,14 @@ mkSDataCon dc = SDataCon , sdcRep = if | GHC.isUnboxedSumDataCon dc -> error "unboxed sum cons are not supported in STG!" | GHC.isUnboxedTupleDataCon dc -> UnboxedTupleCon $ GHC.dataConRepArity dc - | otherwise -> AlgDataCon $ concatMap (concatMap getConArgRep . dcpp "3" GHC.typePrimRep . GHC.scaledThing) $ dcpp "2" GHC.dataConRepArgTys $ dcpp "1" id $ dc + | otherwise -> AlgDataCon dcpp3 , sdcWorker = cvtBinderId idDetails "dataConWorkId" workerId , sdcDefLoc = cvtSrcSpan $ GHC.nameSrcSpan n } where + dcpp1 = dcpp "1" id dc + dcpp2 = dcpp "2" GHC.dataConRepArgTys dcpp1 + dcpp3 = concatMap (concatMap getConArgRep . dcpp "3" GHC.typePrimRep . GHC.scaledThing) $ dcpp2 + dataConId = DataConId . cvtUnique . GHC.getUnique $ n workerId = GHC.dataConWorkId dc @@ -723,7 +844,7 @@ mkSDataCon dc = SDataCon -> DataConWorkId dataConId _ -> error $ "invalid IdDetails for DataCon worker id: " ++ ppr (dc, workerId) - dcpp :: GHC.Outputable o => String -> (o -> a) -> o -> a + dcpp :: String -> (o -> a) -> o -> a dcpp _ f x = f x --dcpp msg f a = trace ("mkSDataCon " ++ msg ++ " : " ++ ppr a) $ f a n = GHC.getName dc @@ -734,5 +855,5 @@ mkSDataCon dc = SDataCon topBindIds :: GHC.CgStgTopBinding -> [GHC.Id] topBindIds = \case GHC.StgTopLifted (GHC.StgNonRec b _) -> [b] - GHC.StgTopLifted (GHC.StgRec bs) -> map fst bs + GHC.StgTopLifted (GHC.StgRec bs) -> fmap fst bs GHC.StgTopStringLit b _ -> [b] diff --git a/wpc-plugin/src/WPC/Stubs.hs b/wpc-plugin/src/WPC/Stubs.hs index 0154e7a..54a02a3 100644 --- a/wpc-plugin/src/WPC/Stubs.hs +++ b/wpc-plugin/src/WPC/Stubs.hs @@ -1,28 +1,53 @@ module WPC.Stubs where -import GHC.Plugins -import GHC.Types.ForeignStubs -import GHC.Types.ForeignCall -import GHC.Driver.CodeOutput -import GHC.Driver.Pipeline.Execute -import Language.Haskell.Syntax.Decls -import WPC.ForeignStubDecls +import Control.Monad (mapM_) -import System.Directory -import System.FilePath +import Data.Bool (Bool (..)) +import Data.Function (($), (.)) +import Data.List ( (++), foldr1 ) +import Data.Maybe ( fromMaybe ) +import Data.String (String) -import Data.Maybe +import GHC.Driver.CodeOutput (outputForeignStubs) +import GHC.Driver.Pipeline.Execute (compileStub) +import GHC.Plugins (DynFlags (..), GenLocated (..), GenModule (..), HscEnv (..), + ModLocation, Module, ModuleName, Outputable (..), hsc_units, showSDoc, + split) +import GHC.Types.ForeignCall (CCallConv (..)) +import GHC.Types.ForeignStubs (ForeignStubs) -outputCapiStubs :: HscEnv -> Module -> ModLocation -> [(ForeignStubs, StubDecl)] -> IO () +import Language.Haskell.Syntax.Decls (ForeignImport (..)) + +import System.Directory (copyFile, createDirectoryIfMissing) +import System.FilePath (FilePath, takeDirectory, takeExtension, ()) +import System.IO (IO, putStrLn) + +import WPC.ForeignStubDecls (StubDecl (..), mergeForeignStubs) + +outputCapiStubs + :: HscEnv + -> Module + -> ModLocation + -> [(ForeignStubs, StubDecl)] + -> IO () outputCapiStubs hscEnv cg_module modLocation stubDecls = do let dflags = hsc_dflags hscEnv tmpfs = hsc_tmpfs hscEnv logger = hsc_logger hscEnv modName = moduleName cg_module - capiStubs = mergeForeignStubs [s | (s, StubDeclImport (CImport _srcText(L _ CApiConv) _safety _mHeader _spec) _) <- stubDecls] + capiStubs = mergeForeignStubs + [s | (s, StubDeclImport (CImport _ (L _ CApiConv) _ _ _) _) <- stubDecls] - (_has_h, maybe_capi_stub_c) <- outputForeignStubs logger tmpfs dflags (hsc_units hscEnv) cg_module modLocation capiStubs + (_has_h, maybe_capi_stub_c) <- + outputForeignStubs + logger + tmpfs + dflags + (hsc_units hscEnv) + cg_module + modLocation + capiStubs mapM_ (compileCapiStubs hscEnv modName) maybe_capi_stub_c compileCapiStubs :: HscEnv -> ModuleName -> FilePath -> IO () @@ -35,7 +60,13 @@ compileCapiStubs hscEnv modName capi_stub_c = do pp = showSDoc dflags . ppr stubPath = foldr1 () . split '.' $ pp modName - wpcCapiStub = odir "extra-compilation-artifacts" "wpc-plugin" "capi-stubs" stubPath "capi_stub" ++ takeExtension capi_stub_o + wpcCapiStub = + odir + "extra-compilation-artifacts" + "wpc-plugin" + "capi-stubs" + stubPath + "capi_stub" ++ takeExtension capi_stub_o putStrLn $ "compileCapiStubs odir - " ++ odir putStrLn $ "compileCapiStubs capi_stub_o - " ++ capi_stub_o diff --git a/wpc-plugin/src/WPC/Yaml.hs b/wpc-plugin/src/WPC/Yaml.hs index f91f60c..3012c54 100644 --- a/wpc-plugin/src/WPC/Yaml.hs +++ b/wpc-plugin/src/WPC/Yaml.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} module WPC.Yaml where -import GHC.Prelude -import GHC.Utils.Json -import GHC.Utils.Outputable +import GHC.Prelude (Bool (..), ($)) +import GHC.Utils.Json (JsonDoc (..), escapeJsonString) +import GHC.Utils.Outputable (IsDoc (..), IsLine (..), Outputable (..), SDoc, colon, doubleQuotes, nest, ($+$)) renderYAML :: JsonDoc -> SDoc renderYAML d = diff --git a/wpc-plugin/stack.yaml b/wpc-plugin/stack.yaml deleted file mode 100644 index 31de6a3..0000000 --- a/wpc-plugin/stack.yaml +++ /dev/null @@ -1,10 +0,0 @@ -resolver: nightly-2023-01-02 -allow-newer: true - -packages: - - . - - external-stg-syntax - -# HINT: wpc-plugin relies on GHC 9.6 plugin API -compiler: ghc-9.6.1 -compiler-check: match-exact diff --git a/wpc-plugin/wpc-plugin.cabal b/wpc-plugin/wpc-plugin.cabal index e386285..d1f5ce4 100644 --- a/wpc-plugin/wpc-plugin.cabal +++ b/wpc-plugin/wpc-plugin.cabal @@ -1,9 +1,9 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: wpc-plugin version: 1.1.0 -- A short (one-line) description of the package. -synopsis: WPC plugin for GHC 9.10.1 +synopsis: WPC plugin for GHC 9.12.2 -- A longer description of the package. -- description: @@ -21,7 +21,28 @@ maintainer: csaba.hruska@gmail.com -- category: extra-source-files: CHANGELOG.md +common lang + default-language: GHC2024 + default-extensions: + DeriveAnyClass + GeneralizedNewtypeDeriving + NoImplicitPrelude + OverloadedStrings + RecordWildCards + MultiWayIf + ImplicitParams + ghc-options: + -Wall + -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Widentities + -Wunused-packages + -Wmissing-deriving-strategies + library + import: lang exposed-modules: WPC.Plugin WPC.Modpak WPC.StgToExtStg @@ -49,11 +70,10 @@ library ghc-boot, mtl hs-source-dirs: src - default-language: Haskell2010 foreign-library wpc-plugin - type: native-shared - default-language: Haskell2010 + import: lang + type: native-shared hs-source-dirs: src ghc-options: -this-unit-id wpc-plugin-unit