diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 51cf1f3..b8ef5c1 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,17 +8,14 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# REGENDATA ["github","derive-storable-plugin.cabal"] +# version: 0.16 +# +# REGENDATA ("0.16",["github","derive-storable-plugin.cabal"]) # name: Haskell-CI on: - push: - branches: - - master - - develop/** - pull_request: - branches: - - master + - push + - pull_request jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} @@ -26,11 +23,16 @@ jobs: timeout-minutes: 60 container: - image: buildpack-deps:jammy + image: buildpack-deps:bionic continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: + - compiler: ghc-9.6.1 + compilerKind: ghc + compilerVersion: 9.6.1 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.4.2 compilerKind: ghc compilerVersion: 9.4.2 @@ -54,22 +56,22 @@ jobs: - compiler: ghc-8.8.1 compilerKind: ghc compilerVersion: 8.8.1 - setup-method: ghcup + setup-method: hvr-ppa allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 - setup-method: ghcup + setup-method: hvr-ppa allow-failure: false - compiler: ghc-8.4.2 compilerKind: ghc compilerVersion: 8.4.2 - setup-method: ghcup + setup-method: hvr-ppa allow-failure: false - compiler: ghc-8.2.2 compilerKind: ghc compilerVersion: 8.2.2 - setup-method: ghcup + setup-method: hvr-ppa allow-failure: false fail-fast: false steps: @@ -77,11 +79,21 @@ jobs: run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + if [ "${{ matrix.setup-method }}" = ghcup ]; then + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + else + apt-add-repository -y 'ppa:hvr/ghc' + apt-get update + apt-get install -y "$HCNAME" + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + fi env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -93,11 +105,20 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + if [ "${{ matrix.setup-method }}" = ghcup ]; then + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" + echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + else + HC=$HCDIR/bin/$HCKIND + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" + echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + fi + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" @@ -132,10 +153,6 @@ jobs: url: http://hackage.haskell.org/ EOF cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz - echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz + echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan rm -f cabal-plan.xz chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - - name: install cabal-docspec - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20211114/cabal-docspec-0.0.0.20211114.xz > cabal-docspec.xz - echo 'e224700d9e8c9ec7ec6bc3f542ba433cd9925a5d356676c62a9bd1f2c8be8f8a cabal-docspec.xz' | sha256sum -c - - xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec - rm -f cabal-docspec.xz - chmod a+x $HOME/.cabal/bin/cabal-docspec - cabal-docspec --version - - name: install doctest - run: | - if [ $((HCNUMVER < 90000)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.20' ; fi - if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest --version ; fi - name: checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: path: source - name: initial cabal.project for sdist run: | touch cabal.project - echo "packages: $GITHUB_WORKSPACE/source/" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project cat cabal.project - name: sdist run: | @@ -200,28 +199,19 @@ jobs: touch cabal.project touch cabal.project.local echo "packages: ${PKGDIR_derive_storable_plugin}" >> cabal.project + echo "package derive-storable-plugin" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(derive-storable-plugin)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - - name: cache - uses: actions/cache@v2 + - name: restore cache + uses: actions/cache/restore@v3 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store @@ -239,31 +229,20 @@ jobs: - name: tests run: | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - - name: doctest - run: | - perl -i -e 'while () { print unless /package-id\s+(base-compat-batteries|bs-cmpt-bttrs)-\d+(\.\d+)*/; }' .ghc.environment.* - if [ $((HCNUMVER < 90000)) -ne 0 ] ; then cd ${PKGDIR_derive_storable_plugin} || false ; fi - if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest --fast -XHaskell2010 src ; fi - - name: docspec - run: | - $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all - cabal-docspec $ARG_COMPILER --verbose --timeout 2 - name: cabal check run: | cd ${PKGDIR_derive_storable_plugin} || false ${CABAL} -vnormal check - name: haddock run: | - $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all - name: unconstrained build run: | rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - - name: prepare for constraint sets - run: | - rm -f cabal.project.local - - name: constraint set deepseq-1.4 - run: | - if [ $((HCNUMVER < 80400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='deepseq ==1.4.*' --constraint='binary installed' --dependencies-only -j2 all ; fi - if [ $((HCNUMVER < 80400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='deepseq ==1.4.*' --constraint='binary installed' all ; fi - if [ $((HCNUMVER < 80400)) -ne 0 ] ; then $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK --disable-tests --disable-benchmarks --constraint='deepseq ==1.4.*' --constraint='binary installed' all ; fi + - name: save cache + uses: actions/cache/save@v3 + if: always() + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store diff --git a/.travis.yml b/.travis.yml index 50679b3..4ba45f3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,14 +8,12 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.12.1 -# -# +# version: 0.16 # version: ~> 1.0 language: c os: linux -dist: xenial +dist: bionic git: # whether to recursively clone submodules submodules: false @@ -35,23 +33,32 @@ before_cache: - rm -rfv $CABALHOME/packages/head.hackage jobs: include: - - compiler: ghc-9.0.1 - addons: {"apt":{"packages":["ghc-9.0.1","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main"}]}} + - compiler: ghc-9.6.1 + addons: {"apt":{"packages":["ghc-9.6.1","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} + os: linux + - compiler: ghc-9.4.2 + addons: {"apt":{"packages":["ghc-9.4.2","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} + os: linux + - compiler: ghc-9.2.2 + addons: {"apt":{"packages":["ghc-9.2.2","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} os: linux - - compiler: ghc-8.10.2 - addons: {"apt":{"packages":["ghc-8.10.2","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main"}]}} + - compiler: ghc-9.0.2 + addons: {"apt":{"packages":["ghc-9.0.2","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} + os: linux + - compiler: ghc-8.10.7 + addons: {"apt":{"packages":["ghc-8.10.7","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} os: linux - compiler: ghc-8.8.1 - addons: {"apt":{"packages":["ghc-8.8.1","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main"}]}} + addons: {"apt":{"packages":["ghc-8.8.1","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} os: linux - compiler: ghc-8.6.5 - addons: {"apt":{"packages":["ghc-8.6.5","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main"}]}} + addons: {"apt":{"packages":["ghc-8.6.5","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} os: linux - compiler: ghc-8.4.2 - addons: {"apt":{"packages":["ghc-8.4.2","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main"}]}} + addons: {"apt":{"packages":["ghc-8.4.2","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} os: linux - compiler: ghc-8.2.2 - addons: {"apt":{"packages":["ghc-8.2.2","cabal-install-3.4"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main"}]}} + addons: {"apt":{"packages":["ghc-8.2.2","cabal-install-3.10"],"sources":[{"key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286","sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main"}]}} os: linux before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') @@ -103,7 +110,7 @@ install: echo "packages: ." >> cabal.project - echo 'package derive-storable-plugin' >> cabal.project - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - - | + - "" - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(derive-storable-plugin)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true @@ -130,7 +137,7 @@ script: echo "packages: ${PKGDIR_derive_storable_plugin}" >> cabal.project - echo 'package derive-storable-plugin' >> cabal.project - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - - | + - "" - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(derive-storable-plugin)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true @@ -145,10 +152,10 @@ script: # cabal check... - (cd ${PKGDIR_derive_storable_plugin} && ${CABAL} -vnormal check) # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all + - ${CABAL} v2-haddock --haddock-all $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all -# REGENDATA ("0.12.1",["derive-storable-plugin.cabal","--output",".travis.yml"]) +# REGENDATA ("0.16",["derive-storable-plugin.cabal","--output",".travis.yml"]) # EOF diff --git a/derive-storable-plugin.cabal b/derive-storable-plugin.cabal index 986778f..2fac3be 100644 --- a/derive-storable-plugin.cabal +++ b/derive-storable-plugin.cabal @@ -1,4 +1,4 @@ --- Initial generic-storable-plugin.cabal generated by cabal init. For +-- Initial generic-storable-plugin.cabal generated by cabal init. For -- further documentation, see http://haskell.org/cabal/users-guide/ name: derive-storable-plugin @@ -11,12 +11,12 @@ license: MIT license-file: LICENSE author: Mateusz Kłoczko maintainer: mateusz.p.kloczko@gmail.com --- copyright: +-- copyright: category: Foreign build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10 -tested-with: GHC==8.2.2, GHC==8.4.2, GHC==8.6.5, GHC==8.8.1, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2, GHC==9.4.2 +tested-with: GHC==8.2.2, GHC==8.4.2, GHC==8.6.5, GHC==8.8.1, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2, GHC==9.4.2, GHC==9.6.1 Flag sumtypes Description: Use sumtypes within benchmark and tests. @@ -32,7 +32,7 @@ library , Foreign.Storable.Generic.Plugin.Internal.Predicates , Foreign.Storable.Generic.Plugin.Internal.Types other-extensions: DeriveGeneric, DeriveAnyClass, PatternGuards - build-depends: base >=4.10 && <5, ghc >= 8.2 && < 9.5, ghci >= 8.2 && < 9.5, derive-storable >= 0.3 && < 0.4 + build-depends: base >=4.10 && <5, ghc >= 8.2 && < 9.7, ghci >= 8.2 && < 9.7, derive-storable >= 0.3 && < 0.4 hs-source-dirs: src default-language: Haskell2010 @@ -53,16 +53,15 @@ benchmark plugin-benchmark test-suite c_alignment type: exitcode-stdio-1.0 - + hs-source-dirs: test/Basic, test/Basic/cbits - c-sources: test/Basic/cbits/TestCases.c + c-sources: test/Basic/cbits/TestCases.c main-is: MemoryCSpec.hs - other-modules: TestCases + other-modules: TestCases build-depends: base >= 4.10 && < 5, derive-storable, derive-storable-plugin , hspec >= 2.4, QuickCheck >= 2.10 - , ghc >= 8.2 && < 9.5, ghci >= 8.2 && < 9.5 - + , ghc >= 8.2 && < 9.7, ghci >= 8.2 && < 9.7 + default-language: Haskell2010 if flag(sumtypes) cpp-options: -DGSTORABLE_SUMTYPES - diff --git a/src/Foreign/Storable/Generic/Plugin.hs b/src/Foreign/Storable/Generic/Plugin.hs index 4835efc..5ab4ca6 100644 --- a/src/Foreign/Storable/Generic/Plugin.hs +++ b/src/Foreign/Storable/Generic/Plugin.hs @@ -6,7 +6,7 @@ Maintainer : mateusz.p.kloczko@gmail.com Stability : experimental Portability : GHC-only -GHC Core plugin for optimising GStorable instances. +GHC Core plugin for optimising GStorable instances. For more information please refer to generic-storable package. How to enable: @@ -18,7 +18,10 @@ How to enable: {-# LANGUAGE CPP #-} module Foreign.Storable.Generic.Plugin (plugin) where - +#if MIN_VERSION_GLASGOW_HASKELL(9,6,1,0) +import GHC.Core.Opt.Simplify.Env (SimplMode (sm_phase)) +import GHC.Core.Opt.Simplify (so_mode) +#endif #if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) import GHC.Plugins #else @@ -46,33 +49,37 @@ plugin = defaultPlugin { defFlags = Flags Some False orderingPass :: Flags -> IORef [[Type]] -> CoreToDo -orderingPass flags io_ref = CoreDoPluginPass "GStorable - type ordering" +orderingPass flags io_ref = CoreDoPluginPass "GStorable - type ordering" (groupTypes flags io_ref) substitutionPass :: Flags -> IORef [[Type]] -> CoreToDo -substitutionPass flags io_ref = CoreDoPluginPass "GStorable - substitution" +substitutionPass flags io_ref = CoreDoPluginPass "GStorable - substitution" (gstorableSubstitution flags io_ref) -- | Checks whether the core pass is a simplifier phase 0. -isPhase0 :: CoreToDo +isPhase0 :: CoreToDo -> Bool +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +isPhase0 (CoreDoSimplify simpl_mode) = case sm_phase $ (so_mode simpl_mode) of +#else isPhase0 (CoreDoSimplify iters simpl_mode) = case sm_phase $ simpl_mode of +#endif Phase 0 -> True - _ -> False + _ -> False isPhase0 _ = False --- | Return the index of simplifier phase 0. +-- | Return the index of simplifier phase 0. afterPhase0 :: [CoreToDo] -> Maybe Int -afterPhase0 todos = findIndex isPhase0 todos +afterPhase0 todos = findIndex isPhase0 todos -- | Checks whether the core pass is a specialising pass. isSpecialize :: CoreToDo -> Bool isSpecialize CoreDoSpecialising = True isSpecialize _ = False --- | Return the index of the specialising pass. +-- | Return the index of the specialising pass. afterSpecialize :: [CoreToDo] -> Maybe Int -afterSpecialize todos = findIndex isSpecialize todos +afterSpecialize todos = findIndex isSpecialize todos -- | Set the verbosity and ToCrash flags based on supplied arguments. setOpts :: Flags -> String -> Flags @@ -87,7 +94,7 @@ parseOpts :: [CommandLineOption] -> Flags parseOpts opts = foldl' setOpts defFlags opts -putPasses :: Flags -> [CoreToDo] -> Int -> Int -> CoreM [CoreToDo] +putPasses :: Flags -> [CoreToDo] -> Int -> Int -> CoreM [CoreToDo] putPasses flags todos ph0 sp = do the_ioref <- liftIO $ newIORef [] let (before_spec,after_spec) = splitAt sp todos @@ -104,10 +111,10 @@ install_err flags = do printer = case verb of None -> return () other -> putMsg $ text "The GStorable plugin requires simplifier phases with inlining and rules on, as well as a specialiser phase." - $$ text "Try to compile the code with -O1 or -O2 optimisation flags." + $$ text "Try to compile the code with -O1 or -O2 optimisation flags." printer when to_crash $ (return $ error "Crashing...") - + install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] diff --git a/src/Foreign/Storable/Generic/Plugin/Internal.hs b/src/Foreign/Storable/Generic/Plugin/Internal.hs index 5be8a92..16db996 100644 --- a/src/Foreign/Storable/Generic/Plugin/Internal.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal.hs @@ -11,7 +11,7 @@ Contains methods for calculating type ordering and performing the compile-substi -} {-#LANGUAGE CPP #-} -module Foreign.Storable.Generic.Plugin.Internal +module Foreign.Storable.Generic.Plugin.Internal ( groupTypes , gstorableSubstitution) where @@ -38,21 +38,31 @@ import GHC.Unit.Module.ModGuts (ModGuts(..)) #else import GHC.Driver.Types (HscEnv,ModGuts(..)) #endif +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Core.Opt.Pipeline.Types (CoreToDo(..)) +#else +import GHC.Core.Opt.Monad (CoreToDo(..)) +#endif import GHC.Core.Opt.Monad - (CoreM, CoreToDo(..), - getHscEnv, getDynFlags, putMsg, putMsgS) + (CoreM, getHscEnv, getDynFlags, putMsg, putMsgS) import GHC.Types.Basic (CompilerPhase(..)) import GHC.Core.Type (isAlgType, splitTyConApp_maybe) import GHC.Core.TyCon (tyConKind, algTyConRhs, visibleDataCons) -import GHC.Core.TyCo.Rep (Type(..), TyBinder(..)) +import GHC.Core.TyCo.Rep (Type(..)) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Var (PiTyBinder(..)) +#define TyBinder PiTyBinder +#else +import GHC.Core.TyCo.Rep (TyBinder(..)) +#endif import GHC.Builtin.Types (intDataCon) -import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) +import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) import GHC.Core.Make (mkWildValBinder) -import GHC.Utils.Outputable +import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe, - ($$), ($+$), hsep, vcat, empty,text, - (<>), (<+>), nest, int, colon,hcat, comma, - punctuate, fsep) + ($$), ($+$), hsep, vcat, empty,text, + (<>), (<+>), nest, int, colon,hcat, comma, + punctuate, fsep) import GHC.Core.Opt.Monad (putMsg, putMsgS) #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt) @@ -67,21 +77,21 @@ import SrcLoc (noSrcSpan) import Unique (getUnique) import HscMain (hscCompileCoreExpr) import HscTypes (HscEnv,ModGuts(..)) -import CoreMonad - (CoreM, CoreToDo(..), +import CoreMonad + (CoreM, CoreToDo(..), getHscEnv, getDynFlags, putMsg, putMsgS) import BasicTypes (CompilerPhase(..)) import Type (isAlgType, splitTyConApp_maybe) import TyCon (tyConKind, algTyConRhs, visibleDataCons) import TyCoRep (Type(..), TyBinder(..)) import TysWiredIn (intDataCon) -import DataCon (dataConWorkId,dataConOrigArgTys) +import DataCon (dataConWorkId,dataConOrigArgTys) import MkCore (mkWildValBinder) -import Outputable +import Outputable (cat, ppr, SDoc, showSDocUnsafe, - ($$), ($+$), hsep, vcat, empty,text, - (<>), (<+>), nest, int, colon,hcat, comma, - punctuate, fsep) + ($$), ($+$), hsep, vcat, empty,text, + (<>), (<+>), nest, int, colon,hcat, comma, + punctuate, fsep) import CoreMonad (putMsg, putMsgS) #endif @@ -93,7 +103,7 @@ import Data.Either import Data.IORef import Debug.Trace import Control.Monad.IO.Class -import Control.Monad +import Control.Monad import Foreign.Storable.Generic.Plugin.Internal.Error import Foreign.Storable.Generic.Plugin.Internal.Compile @@ -127,7 +137,7 @@ groupTypes_errors flags errors = do other -> pprError verb other printer errs = case errs of [] -> return () - ls -> putMsg $ print_header (vcat (map print_err errs)) + ls -> putMsg $ print_header (vcat (map print_err errs)) -- Do printing -- Eventually crash. printer errors @@ -171,7 +181,7 @@ groupTypes flags type_order_ref guts = do bad_types_zip id m_t = case m_t of Nothing -> Just $ TypeNotFound id Just _ -> Nothing - bad_types = catMaybes $ zipWith bad_types_zip gstorable_ids m_gstorable_types + bad_types = catMaybes $ zipWith bad_types_zip gstorable_ids m_gstorable_types -- type_list is used instead of type_set because Type has no uniquable instance. type_list = [ t | Just t <- m_gstorable_types] -- Calculate the type ordering. @@ -179,7 +189,7 @@ groupTypes flags type_order_ref guts = do groupTypes_info flags type_order groupTypes_errors flags bad_types - + liftIO $ writeIORef type_order_ref type_order return guts @@ -192,7 +202,7 @@ groupTypes flags type_order_ref guts = do -- | Print errors related to CoreBind grouping. -- Return the badly grouped bindings, and perhaps crash -- the compiler. -grouping_errors :: Flags -- ^ Verbosity and ToCrash options +grouping_errors :: Flags -- ^ Verbosity and ToCrash options -> Maybe Error -- ^ The error -> CoreM [CoreBind] -- ^ Recovered bindings. grouping_errors flags m_err = do @@ -204,10 +214,10 @@ grouping_errors flags m_err = do print_header txt = case verb of None -> empty other -> text "Errors while grouping bindings: " - $$ nest 4 txt + $$ nest 4 txt printer m_err = case m_err of Nothing -> return () - Just err -> putMsg $ print_header (pprError verb err) + Just err -> putMsg $ print_header (pprError verb err) ungroup m_e = case m_e of Just (OrderingFailedBinds _ rest) -> rest _ -> [] @@ -217,7 +227,7 @@ grouping_errors flags m_err = do -- | Print the information related to found GStorable ids. -foundBinds_info :: Flags -- ^ Verbosity and ToCrash options +foundBinds_info :: Flags -- ^ Verbosity and ToCrash options -> [Id] -- ^ GStorable ids. -> CoreM () foundBinds_info flags ids = do @@ -237,7 +247,7 @@ foundBinds_info flags ids = do -- Use eqType for maybes eqType_maybe (Just t1) (Just t2) = t1 `eqType` t2 eqType_maybe _ _ = False - -- group and sort the bindings + -- group and sort the bindings grouped = groupBy (\i1 i2 -> (getGStorableType $ varType i1) `eqType_maybe` (getGStorableType $ varType i2) ) ids sorting = sortBy (\i1 i2 -> varName i1 `compare` varName i2) sorted = map sorting grouped @@ -247,7 +257,7 @@ foundBinds_info flags ids = do (h:_) -> case getGStorableType $ varType h of Just gtype -> ppr gtype $+$ (fsep $ punctuate comma (map print_binding the_group)) - Nothing -> ppr "Could not get the type of a binding:" + Nothing -> text "Could not get the type of a binding:" $+$ nest 4 (ppr h <+> text "::" <+> ppr (varType h)) -- Print the ids printer sorted @@ -257,8 +267,8 @@ gstorableSubstitution :: Flags -- ^ Verbosity and ToCrash options. -> IORef [[Type]] -- ^ Reference to grouped types. -> ModGuts -- ^ Information about compiled module. -> CoreM ModGuts -- ^ Information about compiled module, with GStorable optimisations. -gstorableSubstitution flags type_order_ref guts = do - type_hierarchy <- liftIO $ readIORef type_order_ref +gstorableSubstitution flags type_order_ref guts = do + type_hierarchy <- liftIO $ readIORef type_order_ref let binds = mg_binds guts -- Get all GStorable binds. -- Check whether the type has no constraints. @@ -267,18 +277,18 @@ gstorableSubstitution flags type_order_ref guts = do else getGStorableMethodType t -- predicate = toIsBind (withTypeCheck typeCheck isGStorableMethodId) predicate = toIsBind (isGStorableMethodId) - + (gstorable_binds,rest) = partition predicate binds -- Check if there are any recursives somehow -- The plugin won't be able to handle them. (nonrecs, recs) = partition isNonRecBind gstorable_binds -- Group the gstorables by nestedness (grouped_binds, m_err_group) = groupBinds type_hierarchy nonrecs - - foundBinds_info flags $ concatMap getIdsBind $ concat grouped_binds + + foundBinds_info flags $ concatMap getIdsBind $ concat grouped_binds -- Check for errors not_grouped <- grouping_errors flags m_err_group -- Compile and replace gstorable bindings new_gstorables <- compileGroups flags grouped_binds rest -- perhaps return errors here ? - + return $ guts {mg_binds = concat [new_gstorables, not_grouped,recs,rest]} diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs index f1be712..7e449bf 100644 --- a/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs @@ -10,8 +10,8 @@ The core of compile and substitute optimisations. -} {-#LANGUAGE CPP#-} -module Foreign.Storable.Generic.Plugin.Internal.Compile - ( +module Foreign.Storable.Generic.Plugin.Internal.Compile + ( -- Compilation compileExpr , tryCompileExpr @@ -60,16 +60,21 @@ import GHC.Unit.Module.ModGuts (ModGuts(..)) #else import GHC.Driver.Types (HscEnv,ModGuts(..)) #endif -import GHC.Core.Opt.Monad (CoreM,CoreToDo(..),getHscEnv,getDynFlags) +import GHC.Core.Opt.Monad (CoreM,getHscEnv,getDynFlags) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Core.Opt.Pipeline.Types (CoreToDo(..)) +#else +import GHC.Core.Opt.Monad (CoreToDo(..)) +#endif import GHC.Core.Lint (lintExpr) import GHC.Types.Basic (CompilerPhase(..), Boxity(..)) import GHC.Core.Type import GHC.Core.TyCon (algTyConRhs, visibleDataCons) -import GHC.Builtin.Types -import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) +import GHC.Builtin.Types +import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) import GHC.Core.Make (mkWildValBinder) import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe) -import GHC.Utils.Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma) +import GHC.Utils.Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma) import GHC.Core.Opt.Monad (putMsg, putMsgS) import GHC.Builtin.Names (buildIdKey, augmentIdKey) import GHC.Builtin.Types.Prim (intPrimTy) @@ -91,11 +96,11 @@ import CoreLint (lintExpr) import BasicTypes (CompilerPhase(..), Boxity(..)) import Type (isAlgType, splitTyConApp_maybe) import TyCon (algTyConRhs, visibleDataCons) -import TysWiredIn -import DataCon (dataConWorkId,dataConOrigArgTys) +import TysWiredIn +import DataCon (dataConWorkId,dataConOrigArgTys) import MkCore (mkWildValBinder) import Outputable (cat, ppr, SDoc, showSDocUnsafe) -import Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma) +import Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma) import CoreMonad (putMsg, putMsgS) import PrelNames (buildIdKey, augmentIdKey) import TysPrim (intPrimTy) @@ -107,7 +112,13 @@ import TysPrim (intPrimTy) import GHCi.RemoteTypes -#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) +import GHC.Core.TyCo.Rep (Type(..), scaledThing) +import GHC.Types.Var +import GHC.Driver.Config.Core.Lint (initLintConfig) +#define Many ManyTy +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing) import GHC.Types.Var @@ -148,13 +159,13 @@ import Literal (LitNumType(..)) -- import CoreMonad (CoreM,CoreToDo(..), getHscEnv, getDynFlags) -- import CoreLint (lintExpr) -- import BasicTypes (CompilerPhase(..)) --- -- Haskell types +-- -- Haskell types -- import Type (isAlgType, splitTyConApp_maybe) -- import TyCon (tyConName, algTyConRhs, visibleDataCons) -- import TyCoRep (Type(..), TyBinder(..), TyLit(..)) -- import TysWiredIn -- import TysPrim (intPrimTy) --- import DataCon (dataConWorkId,dataConOrigArgTys) +-- import DataCon (dataConWorkId,dataConOrigArgTys) import Unsafe.Coerce @@ -174,12 +185,18 @@ import Foreign.Storable.Generic.Plugin.Internal.Error import Foreign.Storable.Generic.Plugin.Internal.Predicates import Foreign.Storable.Generic.Plugin.Internal.Types +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +-- See 778c6adca2c995cd8a1b84394d4d5ca26b915dac +type TyBinder = PiTyBinder +type TyCoVarBinder = ForAllTyBinder +#endif + --------------------- -- compile helpers -- --------------------- -- | Compile an expression. -compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a +compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a compileExpr hsc_env expr src_span = do #if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) (foreign_hval, _, _) <- @@ -188,7 +205,7 @@ compileExpr hsc_env expr src_span = do #endif liftIO $ hscCompileCoreExpr hsc_env src_span expr hval <- liftIO $ withForeignRef foreign_hval localRef - let val = unsafeCoerce hval :: a + let val = unsafeCoerce hval :: a -- finalizeForeignRef foreign_hval -- check whether that's the source of the error return val @@ -196,7 +213,7 @@ compileExpr hsc_env expr src_span = do tryCompileExpr :: Id -> CoreExpr -> CoreM (Either Error a) tryCompileExpr id core_expr = do hsc_env <- getHscEnv - e_compiled <- liftIO $ try $ + e_compiled <- liftIO $ try $ compileExpr hsc_env core_expr (getSrcSpan id) :: CoreM (Either SomeException a) case e_compiled of Left se -> return $ Left $ CompilationError (NonRec id core_expr) [stringToPpr $ show se] @@ -223,9 +240,9 @@ intToExpr t i = Lam wild $ App fun arg -- arg = Lit $ MachInt $ fromIntegral i arg = intLiteral i #if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) - wild= mkWildValBinder Many t + wild= mkWildValBinder Many t #else - wild= mkWildValBinder t + wild= mkWildValBinder t #endif -- | For gsizeOf and galignment - calculate the variables. @@ -239,10 +256,10 @@ intSubstitution b@(NonRec id (Lam l1 l@(Lam l2 e@(Lam l3 expr)))) = do hsc_env <- getHscEnv -- Try the subtitution. the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int) - let m_t = getGStorableType (varType id) + let m_t = getGStorableType (varType id) case m_t of Just t -> return $ NonRec id <$> (Lam l1 <$> (Lam l2 <$> (intToExpr t <$> the_integer))) - Nothing -> + Nothing -> return the_integer >> return $ Left $ CompilationError b [text "Type not found"] -- Without GSTORABLE_SUMPTYPES intSubstitution b@(NonRec id (Lam l1 expr)) = do @@ -250,15 +267,15 @@ intSubstitution b@(NonRec id (Lam l1 expr)) = do hsc_env <- getHscEnv -- Try the subtitution. the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int) - let m_t = getGStorableType (varType id) + let m_t = getGStorableType (varType id) case m_t of Just t -> return $ NonRec id <$> (intToExpr t <$> the_integer) - Nothing -> + Nothing -> return the_integer >> return $ Left $ CompilationError b [text "Type not found"] -- For GHC <= 8.6.5 intSubstitution b@(NonRec id e@(App expr g)) = case expr of Lam _ (Lam _ (Lam _ e)) -> intSubstitution $ NonRec id expr - App e t -> do + App e t -> do subs <- intSubstitution $ NonRec id e case subs of Right (NonRec i (Lam l1 (Lam l2 e)) ) -> return (Right $ NonRec i e) @@ -274,11 +291,11 @@ intSubstitutionWorker id expr = do -- Try the subtitution. the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int) -- Get the type. - let m_t = getGStorableType (varType id) + let m_t = getGStorableType (varType id) case m_t of Just t -> return $ NonRec id <$> (intToExpr t <$> the_integer) -- If the compilation error occured, first return it. - Nothing -> + Nothing -> return the_integer >> return $ Left $ CompilationError (NonRec id expr) [text "Type not found"] ----------------------- -- peek substitution -- @@ -291,10 +308,10 @@ offsetSubstitution b@(NonRec id expr) = do e_subs <- offsetSubstitutionTree [] expr let ne_subs = case e_subs of -- Add the text from other error. - Left (OtherError sdoc) + Left (OtherError sdoc) -> Left $ CompilationError b [sdoc] -- Add the information about uncompiled expr. - Left err@(CompilationError _ _) + Left err@(CompilationError _ _) -> Left $ CompilationError b [pprError Some err] a -> a @@ -312,8 +329,8 @@ getScopeId (IntPrimVal id _) = id -- | Get 'CoreExpr' from 'OffsetScope' getScopeExpr :: OffsetScope -> CoreExpr -getScopeExpr (IntList _ expr) = expr -getScopeExpr (IntPrimVal _ expr) = expr +getScopeExpr (IntList _ expr) = expr +getScopeExpr (IntPrimVal _ expr) = expr instance Outputable OffsetScope where ppr (IntList id expr) = ppr id <+> ppr (getUnique id) <+> comma <+> ppr expr @@ -325,13 +342,13 @@ instance Outputable OffsetScope where -- | Create a list expression from Haskell list. intListExpr :: [Int] -> CoreExpr -intListExpr list = intListExpr' (reverse list) empty_list +intListExpr list = intListExpr' (reverse list) empty_list where empty_list = App ( Var $ dataConWorkId nilDataCon) (Type intTy) intListExpr' :: [Int] -> CoreExpr -> CoreExpr intListExpr' [] acc = acc intListExpr' (l:ls) acc = intListExpr' ls $ App int_cons acc - where int_t_cons = App (Var $ dataConWorkId consDataCon) (Type intTy) + where int_t_cons = App (Var $ dataConWorkId consDataCon) (Type intTy) int_val = App (Var $ dataConWorkId intDataCon ) (intLiteral l) int_cons = App int_t_cons int_val @@ -363,10 +380,10 @@ isLitOrGlobal e@(Var id) = Just e isLitOrGlobal _ = Nothing --- | Check whether the given CoreExpr is an id, +-- | Check whether the given CoreExpr is an id, -- and if yes - substitute it. inScopeAll :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr -inScopeAll (el:rest) e@(Var v_id) +inScopeAll (el:rest) e@(Var v_id) | id <- getScopeId el -- Thought uniques will be unique inside. , id == v_id @@ -378,7 +395,7 @@ inScopeAll _ _ = Nothing -- | Is an "$w!!" identifier -isIndexer :: Id +isIndexer :: Id -> Bool isIndexer id = getOccName (varName id) == mkOccName N.varName "$w!!" @@ -386,7 +403,7 @@ isIndexer id = getOccName (varName id) == mkOccName N.varName "$w!!" -- For !! @Int offsets val expressions. caseExprIndex :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr caseExprIndex scope expr - -- A long list of what needs to be inside the expression. + -- A long list of what needs to be inside the expression. | App beg lit <- expr -- Substitute or leave the literal be. Otherwise cancel. , Just lit_expr <- inScopeAll scope lit <|> isLitOrGlobal lit @@ -401,37 +418,37 @@ caseExprIndex scope expr , isIntType intt , isIndexer ix_id -- New expression. - = Just $ App (App (App ix_var t_int) list_expr) lit_expr + = Just $ App (App (App ix_var t_int) list_expr) lit_expr | otherwise = Nothing {- Note [Offset substitution] - ~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - We would like for gpeekByteOff and gpokeByteOff methods to work as fast as + - We would like for gpeekByteOff and gpokeByteOff methods to work as fast as - handwritten versions. This depends on whether the field's offsets are known - - at compile time or not. + - at compile time or not. - - To have offsets at compile time we have look for certain expressions to pop up. - We need to compile them, and later translate them back to Core expressions. - This approach relies on compiler optimisations of GStorable internals, - - like inlining gpeekByteOff' methods and not inlining the calcOffsets functions. + - like inlining gpeekByteOff' methods and not inlining the calcOffsets functions. - If these optimisations do not happen, a compilation error might occur. - - If not, the resulting method might be not as fast as handwritten one. + - If not, the resulting method might be not as fast as handwritten one. - - - We expect to deal with the following expressions: - - - + - - 1) let offsets = ... :: [Int] in expr - - Here we compile the offsets and put them for later use in expr. - - - 2) case $w!! @Int offsets 0# of _ I# x -> alt_expr - - or case $w!! @Int ... 0# of _ I# x -> alt_expr - - - - Here we substitute the offsets if we can, and then we compile the + - or case $w!! @Int ... 0# of _ I# x -> alt_expr + - + - Here we substitute the offsets if we can, and then we compile the - evaluated expression to later replace 'x' occurences in alt_expr. - - @@ -471,14 +488,14 @@ offsetSubstitutionTree scope expr | Let offset_bind in_expr <- expr , NonRec offset_id offset_expr <- offset_bind , isOffsetsId offset_id - = do + = do e_new_s <- exprToIntList offset_id offset_expr case e_new_s of Left err -> return $ Left err Right int_list -> offsetSubstitutionTree (int_list:scope) in_expr - -- Normal let bindings + -- Normal let bindings | Let bind in_expr <- expr - = do + = do subs <- offsetSubstitutionTree scope in_expr -- Substitution for the bindings let sub_idexpr (id,e) = do @@ -486,7 +503,7 @@ offsetSubstitutionTree scope expr return $ (,) id <$> inner_subs sub_bind (NonRec id e) = do inner_subs <- offsetSubstitutionTree scope e - return $ NonRec id <$> inner_subs + return $ NonRec id <$> inner_subs sub_bind (Rec bs) = do inner_subs <- mapM sub_idexpr bs case lefts inner_subs of @@ -506,13 +523,13 @@ offsetSubstitutionTree scope expr #endif , i_prim_con == intDataCon , Just new_case_expr <- caseExprIndex scope case_expr - = do - e_new_s <- exprToIntVal x_id new_case_expr + = do + e_new_s <- exprToIntVal x_id new_case_expr case e_new_s of Left err -> return $ Left err - Right int_val -> offsetSubstitutionTree (int_val:scope) alt_expr - - -- Normal case expressions. + Right int_val -> offsetSubstitutionTree (int_val:scope) alt_expr + + -- Normal case expressions. | Case case_expr cb t alts <- expr = do #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) @@ -533,7 +550,7 @@ offsetSubstitutionTree scope expr -- Find the first error in alternative compilation let c_err = find (\(_,_,e) -> isLeft e) e_new_alts case c_err of - Nothing -> return $ Case <$> new_case_expr + Nothing -> return $ Case <$> new_case_expr <*> pure cb <*> pure t <*> pure [mkAlt a b ne | (a,b,Right ne) <- e_new_alts] Just (_,_,err) -> return err -- Variable. Return it or try to replace it. @@ -554,7 +571,7 @@ offsetSubstitutionTree scope expr -- | Compile the expression in Core Bind and replace it. -compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind) +compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind) compileGStorableBind core_bind -- Substitute gsizeOf | (NonRec id expr) <- core_bind @@ -586,7 +603,7 @@ replaceUnfoldingBind b@(NonRec id expr) = NonRec (setIdInfo id $ setUnfoldingInfo id_info unfolding{uf_tmpl = expr} ) expr | otherwise = b - + -- | Lint a binding lintBind :: CoreBind -- ^ Core binding to use when returning CompilationError @@ -594,7 +611,12 @@ lintBind :: CoreBind -- ^ Core binding to use when returning CompilationError -> CoreM (Either Error CoreBind) -- ^ Success or failure lintBind b_old b@(NonRec id expr) = do dyn_flags <- getDynFlags +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + let lintConfig = initLintConfig dyn_flags [] + case lintExpr lintConfig expr of +#else case lintExpr dyn_flags [] expr of +#endif Just sdoc -> do #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) let err = bagToList sdoc @@ -606,7 +628,12 @@ lintBind b_old b@(NonRec id expr) = do return $ Right b lintBind b_old b@(Rec bs) = do dyn_flags <- getDynFlags +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + let lintConfig = initLintConfig dyn_flags [] + let errs = mapMaybe (\(_,expr) -> lintExpr lintConfig expr) bs +#else let errs = mapMaybe (\(_,expr) -> lintExpr dyn_flags [] expr) bs +#endif #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) let convert = foldMap bagToList #else @@ -639,11 +666,11 @@ replaceIds gstorable_bs other_bs e@(Var id) = replaceIds gstorable_bs other_bs expr -- For recs. The substituted component has to be removed. | isLocalId id - , ([id_here],rest) <- partition (\x -> id `elem` (map fst x)) $ [bs | Rec bs <- gstorable_bs] + , ([id_here],rest) <- partition (\x -> id `elem` (map fst x)) $ [bs | Rec bs <- gstorable_bs] , Just (_,expr) <- find ((id==).fst) id_here = replaceIds (map Rec rest) other_bs expr | isLocalId id - , ([id_here],rest) <- partition (\x -> id `elem` (map fst x)) $ [bs | Rec bs <- other_bs] + , ([id_here],rest) <- partition (\x -> id `elem` (map fst x)) $ [bs | Rec bs <- other_bs] , Just (_,expr) <- find ((id==).fst) id_here = replaceIds gstorable_bs (map Rec rest) expr -- If is a global id, or id was not found (local inside the expression) - leave it alone. @@ -681,7 +708,7 @@ compileGroups flags bind_groups bind_rest = compileGroups_rec flags 0 bind_group -- | The insides of compileGroups method. compileGroups_rec :: Flags -- ^ For error handling. -> Int -- ^ Depth, useful for debugging. - -> [[CoreBind]] -- ^ Ordered GStorable bindings. + -> [[CoreBind]] -- ^ Ordered GStorable bindings. -> [CoreBind] -- ^ Other top-level bindings -> [CoreBind] -- ^ Succesfull substitutions. -> [CoreBind] -- ^ Unsuccesfull substitutions. @@ -695,13 +722,13 @@ compileGroups_rec flags d (bg:bgs) bind_rest subs not_subs = do -- Monad transformers would be nice here. case e_compiled of Right bind' -> lintBind bind (replaceUnfoldingBind bind') - _ -> return e_compiled + _ -> return e_compiled -- Compiled (or not) expressions e_compiled <- mapM compile_and_lint layer_replaced let errors = lefts e_compiled - compiled = rights e_compiled - - -- Handle errors + compiled = rights e_compiled + + -- Handle errors not_compiled <- compileGroups_error flags d errors -- Next iteration. compileGroups_rec flags (d+1) bgs bind_rest (concat [compiled,subs]) (concat [not_compiled, not_subs]) @@ -720,13 +747,13 @@ compileGroups_error flags d errors = do -- Print header for this type of errors print_header txt = case verb of None -> empty - other -> text "Errors while compiling and substituting bindings at depth " <+> int d <> text ":" - $$ nest 4 txt + other -> text "Errors while compiling and substituting bindings at depth " <+> int d <> text ":" + $$ nest 4 txt -- Print errors themselves printer errs = case errs of [] -> return () -- Print with header - ls -> putMsg $ print_header (vcat (map (pprError verb) errs)) + ls -> putMsg $ print_header (vcat (map (pprError verb) errs)) -- Get the bindings from errors. ungroup err = case err of (CompilationNotSupported bind) -> Just bind diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs b/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs index 105c7b5..341c535 100644 --- a/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs @@ -9,7 +9,7 @@ Portability : GHC-only Grouping methods, both for types and core bindings. -} {-# LANGUAGE CPP #-} -module Foreign.Storable.Generic.Plugin.Internal.GroupTypes +module Foreign.Storable.Generic.Plugin.Internal.GroupTypes ( -- Type ordering calcGroupOrder @@ -38,12 +38,17 @@ import GHC.Unit.Module.ModGuts (ModGuts(..)) #else import GHC.Driver.Types (HscEnv,ModGuts(..)) #endif -import GHC.Core.Opt.Monad (CoreM,CoreToDo(..)) +import GHC.Core.Opt.Monad (CoreM) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Core.Opt.Pipeline.Types (CoreToDo(..)) +#else +import GHC.Core.Opt.Monad (CoreToDo(..)) +#endif import GHC.Types.Basic (CompilerPhase(..)) import GHC.Core.Type hiding (eqType) import GHC.Core.TyCon import GHC.Builtin.Types (intDataCon) -import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) +import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) import GHC.Core.Make (mkWildValBinder) import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe) import GHC.Utils.Outputable (text, (<+>), ($$), nest) @@ -63,9 +68,9 @@ import HscTypes (HscEnv,ModGuts(..)) import CoreMonad (CoreM,CoreToDo(..), getHscEnv) import BasicTypes (CompilerPhase(..)) import Type hiding (eqType) -import TyCon +import TyCon import TysWiredIn (intDataCon) -import DataCon (dataConWorkId,dataConOrigArgTys) +import DataCon (dataConWorkId,dataConOrigArgTys) import MkCore (mkWildValBinder) import Outputable (cat, ppr, SDoc, showSDocUnsafe) import Outputable (text, (<+>), ($$), nest) @@ -78,7 +83,11 @@ import CoreMonad (putMsg, putMsgS) import GHCi.RemoteTypes -#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) +import GHC.Core.TyCo.Rep (Type(..), scaledThing) +import GHC.Types.Var +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing) import GHC.Types.Var @@ -105,8 +114,13 @@ import Foreign.Storable.Generic.Plugin.Internal.Helpers import Foreign.Storable.Generic.Plugin.Internal.Predicates import Foreign.Storable.Generic.Plugin.Internal.Types +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +-- See 778c6adca2c995cd8a1b84394d4d5ca26b915dac +type TyBinder = PiTyBinder +type TyCoVarBinder = ForAllTyBinder +#endif --- | Calculate the order of types. +-- | Calculate the order of types. calcGroupOrder :: [Type] -> ([[Type]], Maybe Error) calcGroupOrder types = calcGroupOrder_rec types [] @@ -121,9 +135,9 @@ calcGroupOrder_rec types acc = do then (reverse acc, Just $ OrderingFailedTypes (length acc) rest) else calcGroupOrder_rec rest (layer':acc) --- | This could be done more efficently if we'd +-- | This could be done more efficently if we'd -- represent the problem as a graph problem. -calcGroupOrder_iteration :: [Type] -- ^ Type to check +calcGroupOrder_iteration :: [Type] -- ^ Type to check -> [Type] -- ^ Type that are checked -> [Type] -- ^ Type that are in this layer -> [Type] -- ^ Type that are not. @@ -138,19 +152,19 @@ calcGroupOrder_iteration (t:ts) checked accepted rejected = do then calcGroupOrder_iteration ts (t:checked) accepted (t:rejected) else calcGroupOrder_iteration ts (t:checked) (t:accepted) rejected --- | Used for type substitution. +-- | Used for type substitution. -- Whether a TyVar appears, replace it with a Type. type TypeScope = (TyVar, Type) -- | Functions doing the type substitutions. -- Examples --- +-- -- substituteTyCon [(a,Int)] a = Int -- substituteTyCon [(a,Int),(b,Char)] (AType b a) = AType Char Int substituteTyCon :: [TypeScope] -> Type -> Type substituteTyCon [] tc_app = tc_app -substituteTyCon type_scope old@(TyVarTy ty_var) +substituteTyCon type_scope old@(TyVarTy ty_var) -- Substitute simple type variables = case find (\(av,_) -> av == ty_var) type_scope of Just (_, new_type) -> new_type @@ -158,11 +172,11 @@ substituteTyCon type_scope old@(TyVarTy ty_var) substituteTyCon type_scope (TyConApp tc args) -- Substitute type constructors = TyConApp tc $ map (substituteTyCon type_scope) args -substituteTyCon type_scope t = t +substituteTyCon type_scope t = t -- | Get data constructor arguments from an algebraic type. getDataConArgs :: Type -> [Type] -getDataConArgs t +getDataConArgs t | isAlgType t , Just (tc, ty_args) <- splitTyConApp_maybe t , ty_vars <- tyConTyVars tc @@ -172,9 +186,9 @@ getDataConArgs t let type_scope = zip ty_vars ty_args data_cons = concatMap dataConOrigArgTys $ (visibleDataCons.algTyConRhs) tc #if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) - map (substituteTyCon type_scope) (map scaledThing data_cons) + map (substituteTyCon type_scope) (map scaledThing data_cons) #else - map (substituteTyCon type_scope) data_cons + map (substituteTyCon type_scope) data_cons #endif | otherwise = [] @@ -182,10 +196,10 @@ getDataConArgs t -- | Group bindings according to type groups. groupBinds :: [[Type]] -- ^ Type groups. - -> [CoreBind] -- ^ Should be only NonRecs. + -> [CoreBind] -- ^ Should be only NonRecs. -> ([[CoreBind]], Maybe Error) -- perhaps add some safety so non-recs won't get here. -groupBinds type_groups binds = groupBinds_rec type_groups binds [] +groupBinds type_groups binds = groupBinds_rec type_groups binds [] -- | Iteration for groupBinds groupBinds_rec :: [[Type]] -- ^ Group of types @@ -194,8 +208,8 @@ groupBinds_rec :: [[Type]] -- ^ Group of types -> ([[CoreBind]], Maybe Error) -- ^ Grouped bindings, and perhaps an error) groupBinds_rec [] [] acc = (reverse acc,Nothing) groupBinds_rec (a:as) [] acc = (reverse acc,Just $ OtherError msg) - where msg = text "Could not find any bindings." - $$ text "Is the second pass placed after main simplifier phases ?" + where msg = text "Could not find any bindings." + $$ text "Is the second pass placed after main simplifier phases ?" groupBinds_rec [] binds acc = (reverse acc,Just $ OrderingFailedBinds (length acc) binds) groupBinds_rec (tg:tgs) binds acc = do let predicate (NonRec id _) = case getGStorableType $ varType id of @@ -203,6 +217,6 @@ groupBinds_rec (tg:tgs) binds acc = do Nothing -> False predicate (Rec _) = False let (layer, rest) = partition predicate binds - if length layer == 0 + if length layer == 0 then (reverse acc, Just $ OrderingFailedBinds (length acc) rest) else groupBinds_rec tgs rest (reverse layer:acc) diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs index 024981b..750214e 100644 --- a/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs @@ -29,12 +29,17 @@ import GHC.Unit.Module.ModGuts (ModGuts(..)) #else import GHC.Driver.Types (HscEnv,ModGuts(..)) #endif -import GHC.Core.Opt.Monad (CoreM,CoreToDo(..)) +import GHC.Core.Opt.Monad (CoreM) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Core.Opt.Pipeline.Types (CoreToDo(..)) +#else +import GHC.Core.Opt.Monad (CoreToDo(..)) +#endif import GHC.Types.Basic (CompilerPhase(..)) import GHC.Core.Type (isAlgType, splitTyConApp_maybe) import GHC.Core.TyCon (algTyConRhs, visibleDataCons) import GHC.Builtin.Types (intDataCon) -import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) +import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) import GHC.Core.Make (mkWildValBinder) import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe) import GHC.Core.Opt.Monad (putMsg, putMsgS) @@ -55,7 +60,7 @@ import BasicTypes (CompilerPhase(..)) import Type (isAlgType, splitTyConApp_maybe) import TyCon (algTyConRhs, visibleDataCons) import TysWiredIn (intDataCon) -import DataCon (dataConWorkId,dataConOrigArgTys) +import DataCon (dataConWorkId,dataConOrigArgTys) import MkCore (mkWildValBinder) import Outputable (cat, ppr, SDoc, showSDocUnsafe) import CoreMonad (putMsg, putMsgS) @@ -66,8 +71,11 @@ import CoreMonad (putMsg, putMsgS) -- Used to get to compiled values import GHCi.RemoteTypes - -#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) +import GHC.Core.TyCo.Rep (Type(..), scaledThing) +import GHC.Types.Var +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing) import GHC.Types.Var @@ -90,6 +98,11 @@ import Data.Maybe import Data.Either import Control.Monad.IO.Class +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +-- See 778c6adca2c995cd8a1b84394d4d5ca26b915dac +type TyBinder = PiTyBinder +type TyCoVarBinder = ForAllTyBinder +#endif -- | Get ids from core bind. @@ -160,7 +173,9 @@ eqTyBind (Named tvb1) (Named tvb2) = tvb1 `eqTyVarBind` tvb2 #else eqTyBind (Named t1 vis1) (Named t2 vis2) = t1 == t2 && vis1 == vis2 #endif -#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +eqTyBind (Anon t1 _) (Anon t2 _) = scaledThing t1 `eqType` scaledThing t2 +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) eqTyBind (Anon _ t1) (Anon _ t2) = scaledThing t1 `eqType` scaledThing t2 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) eqTyBind (Anon _ t1) (Anon _ t2) = t1 `eqType` t2 @@ -171,11 +186,11 @@ eqTyBind _ _ = False #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool -eqTyVarBind (Bndr t1 arg1) (Bndr t2 arg2) = t1 == t2 +eqTyVarBind (Bndr t1 arg1) (Bndr t2 arg2) = t1 == t2 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) -- | Equality for type variable binders eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool -eqTyVarBind (TvBndr t1 arg1) (TvBndr t2 arg2) = t1 == t2 +eqTyVarBind (TvBndr t1 arg1) (TvBndr t2 arg2) = t1 == t2 #endif -- | 'elem' function for types @@ -185,7 +200,7 @@ elemType t (ot:ts) = (t `eqType` ot) || elemType t ts #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) isProxy :: TyCoVarBinder -> Bool -isProxy (Bndr tycovar flag) +isProxy (Bndr tycovar flag) #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) isProxy :: TyVarBinder -> Bool isProxy (TvBndr tycovar flag) @@ -201,7 +216,7 @@ isProxy (Named tycovar flag) , FunTy _ bool star <- varType tycovar #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy bool star <- varType tycovar -#else +#else , ForAllTy bool star <- varType tycovar #endif = True @@ -218,7 +233,7 @@ removeProxy t , FunTy _ ch t2 <- t1 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy ch t2 <- t1 -#else +#else , ForAllTy ch' t2 <- t , Anon ch <- ch' #endif @@ -235,7 +250,7 @@ removeProxy t , FunTy _ ch t2 <- t1 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy ch t2 <- t1 -#else +#else , ForAllTy ch' t2 <- t , Anon ch <- ch' #endif @@ -252,7 +267,7 @@ removeProxy t , FunTy _ ch t2 <- t1 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy ch t2 <- t1 -#else +#else , ForAllTy ch' t2 <- t , Anon ch <- ch' #endif diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs index 005cac3..c7083e3 100644 --- a/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs @@ -10,7 +10,7 @@ Predicates for finding GStorable identifiers, plus some others. -} {-#LANGUAGE CPP#-} -module Foreign.Storable.Generic.Plugin.Internal.Predicates +module Foreign.Storable.Generic.Plugin.Internal.Predicates ( -- Predicates on identifiers isGStorableInstId @@ -53,13 +53,13 @@ where -- import HscTypes (HscEnv,ModGuts(..)) -- import CoreMonad (CoreM, CoreToDo(..), getHscEnv) -- import BasicTypes (CompilerPhase(..)) --- -- Types +-- -- Types -- import Type (isAlgType, splitTyConApp_maybe) -- import TyCon (TyCon,tyConName, algTyConRhs, visibleDataCons) -- import TyCoRep (Type(..), TyBinder(..)) -- import TysWiredIn (intDataCon) --- import DataCon (dataConWorkId,dataConOrigArgTys) --- +-- import DataCon (dataConWorkId,dataConOrigArgTys) +-- -- import MkCore (mkWildValBinder) -- -- Printing -- import Outputable (cat, ppr, SDoc, showSDocUnsafe) @@ -82,12 +82,17 @@ import GHC.Unit.Module.ModGuts (ModGuts(..)) #else import GHC.Driver.Types (HscEnv,ModGuts(..)) #endif -import GHC.Core.Opt.Monad (CoreM,CoreToDo(..)) +import GHC.Core.Opt.Monad (CoreM) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Core.Opt.Pipeline.Types (CoreToDo(..)) +#else +import GHC.Core.Opt.Monad (CoreToDo(..)) +#endif import GHC.Types.Basic (CompilerPhase(..)) import GHC.Core.Type (isAlgType, splitTyConApp_maybe) import GHC.Core.TyCon (algTyConRhs, visibleDataCons) import GHC.Builtin.Types (intDataCon) -import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) +import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) import GHC.Core.Make (mkWildValBinder) import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe) import GHC.Core.Opt.Monad (putMsg, putMsgS) @@ -109,16 +114,20 @@ import BasicTypes (CompilerPhase(..)) import Type (isAlgType, splitTyConApp_maybe) import TyCon (algTyConRhs, visibleDataCons) import TysWiredIn (intDataCon) -import DataCon (dataConWorkId,dataConOrigArgTys) +import DataCon (dataConWorkId,dataConOrigArgTys) import MkCore (mkWildValBinder) import Outputable (cat, ppr, SDoc, showSDocUnsafe) import CoreMonad (putMsg, putMsgS) import Name (nameStableString) #endif -#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) +import GHC.Core.TyCo.Rep (Type(..), scaledThing) +import GHC.Types.Var +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) -import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing) +import GHC.Core.TyCo.Rep (Type(..), scaledThing) import GHC.Types.Var #elif MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) import Var (TyVarBinder(..), VarBndr(..)) @@ -130,14 +139,19 @@ import TyCoRep (Type(..), TyBinder(..)) import Var #endif -import Data.Maybe +import Data.Maybe import Foreign.Storable.Generic.Plugin.Internal.Helpers +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +-- See 778c6adca2c995cd8a1b84394d4d5ca26b915dac +type TyBinder = PiTyBinder +type TyCoVarBinder = ForAllTyBinder +#endif -- | Predicate used to find GStorable instances identifiers. isGStorableInstId :: Id -> Bool -isGStorableInstId id = cutted_occ_name == gstorable_dict_name +isGStorableInstId id = cutted_occ_name == gstorable_dict_name && cutted_occ_name2 /= gstorable'_dict_name where cutted_occ_name = cutOccName 11 $ getOccName (varName id) cutted_occ_name2 = cutOccName 12 $ getOccName (varName id) @@ -146,11 +160,11 @@ isGStorableInstId id = cutted_occ_name == gstorable_dict_name -- | Predicate used to find gsizeOf identifiers isSizeOfId :: Id -> Bool -isSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$cgsizeOf" +isSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$cgsizeOf" -- | Predicate used to find galignment identifiers isAlignmentId :: Id -> Bool -isAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$cgalignment" +isAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$cgalignment" -- | Predicate used to find gpeekByteOff identifiers isPeekId :: Id -> Bool @@ -174,7 +188,7 @@ isChoiceSizeOfId id = occStr == compared1 || occStr == compared2 where occStr = nameStableString $ varName id compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchSizeOf" compared2 = "$_in$$s$fGStorableChoice'Truea_$cchSizeOf" - + -- | Predicate used to find chAlignment identifiers isChoiceAlignmentId :: Id -> Bool isChoiceAlignmentId id = occStr == compared1 || occStr == compared2 @@ -212,19 +226,19 @@ isSpecGStorableInstId id = cutted_occ_name == gstorable_dict_name -- | Predicate used to find specialized gsizeOf identifiers isSpecSizeOfId :: Id -> Bool -isSpecSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgsizeOf" +isSpecSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgsizeOf" -- | Predicate used to find specialized galignment identifiers isSpecAlignmentId :: Id -> Bool -isSpecAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgalignment" +isSpecAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgalignment" -- | Predicate used to find specialized gpeekByteOff identifiers isSpecPeekId :: Id -> Bool -isSpecPeekId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpeekByteOff" +isSpecPeekId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpeekByteOff" -- | Predicate used to find specialized gpokeByteOff identifiers isSpecPokeId :: Id -> Bool -isSpecPokeId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpokeByteOff" +isSpecPokeId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpokeByteOff" ---------------------------- @@ -252,7 +266,7 @@ isGStorableId id = any ($ id) [ isSizeOfId, isAlignmentId, isPeekId #endif ] -- | Is the id an GStorable method. -isGStorableMethodId :: Id -> Bool +isGStorableMethodId :: Id -> Bool isGStorableMethodId id = any ($ id) [isSizeOfId, isAlignmentId , isPeekId, isPokeId , isSpecSizeOfId, isSpecAlignmentId @@ -262,7 +276,7 @@ isGStorableMethodId id = any ($ id) [isSizeOfId, isAlignmentId , isChoicePeekId, isChoicePokeId #endif ] ------------------- +------------------ -- Miscellanous -- ------------------ diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs index 5e7d6ad..56253f7 100644 --- a/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs @@ -57,12 +57,17 @@ import GHC.Unit.Module.ModGuts (ModGuts(..)) #else import GHC.Driver.Types (HscEnv,ModGuts(..)) #endif -import GHC.Core.Opt.Monad (CoreM,CoreToDo(..)) +import GHC.Core.Opt.Monad (CoreM) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Core.Opt.Pipeline.Types (CoreToDo(..)) +#else +import GHC.Core.Opt.Monad (CoreToDo(..)) +#endif import GHC.Types.Basic (CompilerPhase(..)) import GHC.Core.Type (isAlgType, splitTyConApp_maybe) import GHC.Core.TyCon (TyCon(..),algTyConRhs, visibleDataCons) import GHC.Builtin.Types (intDataCon) -import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) +import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys) import GHC.Core.Make (mkWildValBinder) import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe) import GHC.Core.Opt.Monad (putMsg, putMsgS) @@ -83,7 +88,7 @@ import BasicTypes (CompilerPhase(..)) import Type (isAlgType, splitTyConApp_maybe) import TyCon (TyCon(..),algTyConRhs, visibleDataCons) import TysWiredIn (intDataCon) -import DataCon (dataConWorkId,dataConOrigArgTys) +import DataCon (dataConWorkId,dataConOrigArgTys) import MkCore (mkWildValBinder) import Outputable (cat, ppr, SDoc, showSDocUnsafe) import CoreMonad (putMsg, putMsgS) @@ -118,7 +123,11 @@ import Type (isUnboxedTupleType) #endif -#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) +import GHC.Core.TyCo.Rep (Type(..), scaledThing) +import GHC.Types.Var +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) import GHC.Types.Var (TyVarBinder(..), VarBndr(..)) import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing) import GHC.Types.Var @@ -132,6 +141,13 @@ import TyCoRep (Type(..), TyBinder(..)) import Var #endif +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +-- See 778c6adca2c995cd8a1b84394d4d5ca26b915dac +type TyBinder = PiTyBinder +type TyCoVarBinder = ForAllTyBinder +#endif + + -- | Check whether the type is integer isIntType :: Type -> Bool isIntType (TyConApp int []) = int == intTyCon @@ -177,11 +193,11 @@ isStateRealWorld _ = False -- | Check whether the type constuctor is a GStorable isGStorableInstTyCon :: TyCon -> Bool -isGStorableInstTyCon tc = getOccName (tyConName tc) == mkOccName N.tcClsName "GStorable" +isGStorableInstTyCon tc = getOccName (tyConName tc) == mkOccName N.tcClsName "GStorable" -- | Check whether the type is of kind * -> Constraint. hasConstraintKind :: Type -> Bool -hasConstraintKind ty +hasConstraintKind ty | TyConApp tc [a] <- ty , ForAllTy star kind_ty <- tyConKind tc , TyConApp k_tc [] <- kind_ty @@ -211,7 +227,7 @@ hasGStorableConstraints t getGStorableInstType :: Type -> Maybe Type getGStorableInstType t | hasConstraintKind t - , TyConApp gstorable [the_t] <- t + , TyConApp gstorable [the_t] <- t = Just the_t -- Ignore forall a. a, GStorable a =>, etc.. | ForAllTy _ some_t <- t = getGStorableInstType some_t @@ -283,11 +299,11 @@ getPeekType t = getPeekType' t False False -- | Insides of getPeekType, which takes into the account -- the order of arguments. -getPeekType' :: Type +getPeekType' :: Type -> Bool -- ^ Is after Ptr -> Bool -- ^ Is after Int -> Maybe Type -- ^ Returning -getPeekType' t after_ptr after_int +getPeekType' t after_ptr after_int -- Last step: IO (TheType) | after_ptr, after_int , TyConApp io_tc [the_t] <- t @@ -310,13 +326,13 @@ getPeekType' t after_ptr after_int -- Ptr b -> Int -> IO (TheType) #if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) | ForAllTy ty_bind fun_t <- t - , FunTy _ _ ptr_t rest <- fun_t + , FunTy _ _ ptr_t rest <- fun_t #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) | ForAllTy ty_bind fun_t <- t - , FunTy _ ptr_t rest <- fun_t + , FunTy _ ptr_t rest <- fun_t #elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) | ForAllTy ty_bind fun_t <- t - , FunTy ptr_t rest <- fun_t + , FunTy ptr_t rest <- fun_t #else | ForAllTy ty_bind rest <- t , Anon ptr_t <- ty_bind @@ -324,7 +340,7 @@ getPeekType' t after_ptr after_int , isPtrType ptr_t = getPeekType' rest True False -- Ignore other types - -- including constraints and + -- including constraints and -- Named ty binders. | ForAllTy _ some_t <- t = getPeekType' some_t after_ptr after_int @@ -332,17 +348,17 @@ getPeekType' t after_ptr after_int ---isUnboxedTuple2 is State# h +--isUnboxedTuple2 is State# h -- | Get the type from GStorable poke method getPokeType :: Type -> Maybe Type getPokeType t = getPokeType' t False False -getPokeType' :: Type +getPokeType' :: Type -> Bool -- ^ Is after Ptr -> Bool -- ^ Is after Int -> Maybe Type -- ^ Returning -getPokeType' t after_ptr after_int +getPokeType' t after_ptr after_int -- Last step: TheType -> IO () | after_ptr, after_int #if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0) @@ -387,11 +403,11 @@ getPokeType' t after_ptr after_int #else | ForAllTy ty_bind rest <- t , Anon ptr_t <- ty_bind -#endif +#endif , isPtrType ptr_t = getPokeType' rest True False -- Ignore other types - -- including constraints and + -- including constraints and -- Named ty binders. | ForAllTy _ some_t <- t = getPokeType' some_t after_ptr after_int