.gitlab-ci.yml

@@ -2,20 +2,19 @@ variables:
   GIT_SSL_NO_VERIFY: "1"
 
   # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: 8beb70e553e521796f4250000107c008b477040f
+  DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a
 
   # Sequential version number capturing the versions of all tools fetched by
-  # .gitlab/win32-init.sh.
+  # .gitlab/ci.sh.
   WINDOWS_TOOLCHAIN_VERSION: 1
 
   # Disable shallow clones; they break our linting rules
   GIT_DEPTH: 0
 
-before_script:
-  - git submodule sync --recursive
-  - git submodule update --init --recursive
-  - git checkout .gitmodules
-  - "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
+  # Overridden by individual jobs
+  CONFIGURE_ARGS: ""
+
+  GIT_SUBMODULE_STRATEGY: "recursive"
 
 stages:
   - lint        # Source linting
@@ -36,6 +35,25 @@ stages:
     - tags
     - web
 
+.nightly: &nightly
+  only:
+    variables:
+      - $NIGHTLY
+  artifacts:
+    when: always
+    expire_in: 8 weeks
+
+.release: &release
+  variables:
+    BUILD_FLAVOUR: "perf"
+    FLAVOUR: "perf"
+  artifacts:
+    when: always
+    expire_in: 1 year
+  only:
+    variables:
+      - $RELEASE == "yes"
+
 ############################################################
 # Runner Tags
 ############################################################
@@ -106,7 +124,7 @@ typecheck-testsuite:
     - lint
 
 # We allow the submodule checker to fail when run on merge requests (to
-# accomodate, e.g., haddock changes not yet upstream) but not on `master` or
+# accommodate, e.g., haddock changes not yet upstream) but not on `master` or
 # Marge jobs.
 .lint-submods:
   <<: *only-default
@@ -117,8 +135,7 @@ typecheck-testsuite:
     - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
     - "echo Linting submodule changes between $base..$CI_COMMIT_SHA"
     - git submodule foreach git remote update
-      # TODO: Fix submodule linter
-    - submodchecker . $(git rev-list $base..$CI_COMMIT_SHA) || true
+    - submodchecker . $(git rev-list $base..$CI_COMMIT_SHA)
   dependencies: []
   tags:
     - lint
@@ -162,11 +179,7 @@ lint-submods-branch:
   tags:
     - lint
   script:
-    - |
-      grep TBA libraries/*/changelog.md && (
-          echo "Error: Found \"TBA\"s in changelogs."
-          exit 1
-      )
+    - bash .gitlab/linters/check-changelogs.sh
 
 lint-changelogs:
   extends: .lint-changelogs
@@ -192,25 +205,10 @@ lint-release-changelogs:
   variables:
     FLAVOUR: "validate"
   script:
-    - cabal update
-    - git clean -xdf && git submodule foreach git clean -xdf
-    - .gitlab/prepare-system.sh
-    - if [[ -d ./cabal-cache ]]; then cp -R ./.cabal-cache ~/.cabal-cache; fi
-    - ./boot
-    - ./configure $CONFIGURE_ARGS
-    - hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
-    - mv _build/bindist/ghc*.tar.xz ghc.tar.xz
-    - export TOP=$(pwd)
-    - cd _build/bindist/ghc-*/ && ./configure --prefix=$TOP/_build/install && make install && cd ../../../
-    - |
-      # Prepare to push git notes.
-      export METRICS_FILE=$CI_PROJECT_DIR/performance-metrics.tsv
-      git config user.email "ben+ghc-ci@smart-cactus.org"
-      git config user.name "GHC GitLab CI"
-    - hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --docs=no-sphinx test --summary-junit=./junit.xml --test-compiler=$TOP/_build/install/bin/ghc || (.gitlab/push-test-metrics.sh && false)
-    - |
-      # Push git notes.
-      .gitlab/push-test-metrics.sh
+    - .gitlab/ci.sh setup
+    - .gitlab/ci.sh configure
+    - .gitlab/ci.sh build_hadrian
+    - .gitlab/ci.sh test_hadrian
   cache:
     key: hadrian
     paths:
@@ -235,6 +233,8 @@ lint-release-changelogs:
     - git submodule update --init --recursive
     - git checkout .gitmodules
     - "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
+  after_script:
+    - .gitlab/ci.sh clean
   tags:
     - x86_64-linux
 
@@ -267,7 +267,7 @@ hadrian-ghc-in-ghci:
     - cabal update
     - cd hadrian; cabal new-build --project-file=ci.project; cd ..
     - git clean -xdf && git submodule foreach git clean -xdf
-    - .gitlab/prepare-system.sh
+    - .gitlab/ci.sh setup
     - if [[ -d ./cabal-cache ]]; then cp -R ./.cabal-cache ~/.cabal-cache; fi
     - ./boot
     - ./configure $CONFIGURE_ARGS
@@ -286,27 +286,12 @@ hadrian-ghc-in-ghci:
   <<: *only-default
   variables:
     TEST_TYPE: test
-  before_script:
-    - git clean -xdf && git submodule foreach git clean -xdf
+    MAKE_ARGS: "-Werror"
   script:
-    - ./boot
-    - ./configure $CONFIGURE_ARGS
-    - |
-      THREADS=`mk/detect-cpu-count.sh`
-      make V=0 -j$THREADS WERROR=-Werror
-    - make binary-dist-prep TAR_COMP_OPTS="-1"
-    - make test_bindist TEST_PREP=YES
-    - |
-      # Prepare to push git notes.
-      METRICS_FILE=$CI_PROJECT_DIR/performance-metrics.tsv
-      git config user.email "ben+ghc-ci@smart-cactus.org"
-      git config user.name "GHC GitLab CI"
-    - |
-      THREADS=`mk/detect-cpu-count.sh`
-      make $TEST_TYPE THREADS=$THREADS JUNIT_FILE=../../junit.xml METRICS_FILE=$METRICS_FILE || (METRICS_FILE=$METRICS_FILE .gitlab/push-test-metrics.sh && false)
-    - |
-      # Push git notes.
-      METRICS_FILE=$METRICS_FILE .gitlab/push-test-metrics.sh
+    - .gitlab/ci.sh setup
+    - .gitlab/ci.sh configure
+    - .gitlab/ci.sh build_make
+    - .gitlab/ci.sh test_make
   dependencies: []
   artifacts:
     reports:
@@ -317,6 +302,84 @@ hadrian-ghc-in-ghci:
       - junit.xml
       - performance-metrics.tsv
 
+#################################
+# x86_64-freebsd
+#################################
+
+.build-x86_64-freebsd:
+  extends: .validate
+  tags:
+    - x86_64-freebsd
+  allow_failure: true
+  variables:
+    # N.B. we use iconv from ports as I see linker errors when we attempt
+    # to use the "native" iconv embedded in libc as suggested by the
+    # porting guide [1].
+    # [1] https://www.freebsd.org/doc/en/books/porters-handbook/using-iconv.html)
+    CONFIGURE_ARGS: "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib"
+    GHC_VERSION: 8.6.3
+    CABAL_INSTALL_VERSION: 3.0.0.0
+    BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-portbld-freebsd.tar.xz"
+    TEST_ENV: "x86_64-freebsd"
+    BUILD_FLAVOUR: "validate"
+  after_script:
+    - cp -Rf $HOME/.cabal cabal-cache
+    - .gitlab/ci.sh clean
+  artifacts:
+    when: always
+    expire_in: 2 week
+  cache:
+    key: "freebsd-$GHC_VERSION"
+    paths:
+      - cabal-cache
+      - toolchain
+
+# Disabled due to lack of builder capacity
+.validate-x86_64-freebsd:
+  extends: .build-x86_64-freebsd
+  stage: full-build
+
+nightly-x86_64-freebsd:
+  <<: *nightly
+  extends: .build-x86_64-freebsd
+  stage: full-build
+
+release-x86_64-freebsd:
+  <<: *release
+  extends: .build-x86_64-freebsd
+  stage: full-build
+
+.build-x86_64-freebsd-hadrian:
+  extends: .validate-hadrian
+  stage: full-build
+  tags:
+    - x86_64-freebsd
+  allow_failure: true
+  variables:
+    CONFIGURE_ARGS: "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib"
+    HADRIAN_ARGS: "--docs=no-sphinx"
+    GHC_VERSION: 8.6.3
+    CABAL_INSTALL_VERSION: 3.0.0.0
+    BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-portbld-freebsd.tar.xz"
+    TEST_ENV: "x86_64-freebsd-hadrian"
+    FLAVOUR: "validate"
+  after_script:
+    - cp -Rf $HOME/.cabal cabal-cache
+    - .gitlab/ci.sh clean
+  artifacts:
+    when: always
+    expire_in: 2 week
+  cache:
+    key: "freebsd-$GHC_VERSION"
+    paths:
+      - cabal-cache
+      - toolchain
+
+# Disabled due to lack of builder capacity
+.validate-x86_64-freebsd-hadrian:
+  extends: .build-x86_64-freebsd-hadrian
+  stage: full-build
+
 #################################
 # x86_64-darwin
 #################################
@@ -328,25 +391,18 @@ validate-x86_64-darwin:
     - x86_64-darwin
   variables:
     GHC_VERSION: 8.6.5
-    CABAL_INSTALL_VERSION: 2.4.1.0
+    CABAL_INSTALL_VERSION: 3.0.0.0
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-apple-darwin.tar.xz"
     MACOSX_DEPLOYMENT_TARGET: "10.7"
     # Only Sierra and onwards supports clock_gettime. See #12858
     ac_cv_func_clock_gettime: "no"
     LANG: "en_US.UTF-8"
-    CONFIGURE_ARGS: --with-intree-gmp
+    CONFIGURE_ARGS: "--with-intree-gmp"
     TEST_ENV: "x86_64-darwin"
-  before_script:
-    - git clean -xdf && git submodule foreach git clean -xdf
-    - git submodule sync --recursive
-    - git submodule update --init --recursive
-    - git checkout .gitmodules
-    - "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
-
-    - bash .gitlab/darwin-init.sh
-    - PATH="`pwd`/toolchain/bin:$PATH"
+    BUILD_FLAVOUR: "perf"
   after_script:
     - cp -Rf $HOME/.cabal cabal-cache
+    - .gitlab/ci.sh clean
   artifacts:
     when: always
     expire_in: 2 week
@@ -370,26 +426,14 @@ validate-x86_64-darwin:
     CONFIGURE_ARGS: --with-intree-gmp
     TEST_ENV: "x86_64-darwin-hadrian"
     FLAVOUR: "validate"
-  before_script:
-    - git clean -xdf && git submodule foreach git clean -xdf
-    - git submodule sync --recursive
-    - git submodule update --init --recursive
-    - git checkout .gitmodules
-    - "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
-
-    - bash .gitlab/darwin-init.sh
-    - PATH="`pwd`/toolchain/bin:$PATH"
   script:
-    - cabal update
-    - ./boot
-    - ./configure $CONFIGURE_ARGS
-    - hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
-    - mv _build/bindist/ghc*.tar.xz ghc.tar.xz
-    - export TOP=$(pwd)
-    - cd _build/bindist/ghc-*/ && ./configure --prefix=$TOP/_build/install && make install && cd ../../../
-    - hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --docs=no-sphinx test --summary-junit=./junit.xml --test-compiler=$TOP/_build/install/bin/ghc
+    - .gitlab/ci.sh setup
+    - .gitlab/ci.sh configure
+    - .gitlab/ci.sh build_hadrian
+    - .gitlab/ci.sh test_hadrian
   after_script:
     - cp -Rf $HOME/.cabal cabal-cache
+    - .gitlab/ci.sh clean
   artifacts:
     when: always
     expire_in: 2 week
@@ -403,19 +447,15 @@ validate-x86_64-darwin:
   extends: .validate
   tags:
     - x86_64-linux
+  variables:
+    BUILD_FLAVOUR: "perf"
   before_script:
-    - git clean -xdf && git submodule foreach git clean -xdf
-    - git submodule sync --recursive
-    - git submodule update --init --recursive
-    - git checkout .gitmodules
-    - "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
       # Build hyperlinked sources for documentation when building releases
     - |
       if [[ -n "$CI_COMMIT_TAG" ]]; then
-        echo "EXTRA_HADDOCK_OPTS += --hyperlinked-source --quickjump" >> mk/build.mk
+        HADDOCK_HYPERLINKED_SOURCES=1
       fi
 
-    - .gitlab/prepare-system.sh
     # workaround for docker permissions
     - sudo chown ghc:ghc -R .
   after_script:
@@ -427,71 +467,63 @@ validate-x86_64-darwin:
       - toolchain
 
 #################################
-# aarch64-linux-deb9
+# aarch64-linux-deb10
 #################################
 
-.build-aarch64-linux-deb9:
+.build-aarch64-linux-deb10:
   extends: .validate-linux
   stage: full-build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb9:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb10:$DOCKER_REV"
   allow_failure: true
   variables:
-    TEST_ENV: "aarch64-linux-deb9"
-    BIN_DIST_PREP_TAR_COMP: "ghc-aarch64-linux-deb9.tar.xz"
+    TEST_ENV: "aarch64-linux-deb10"
+    BIN_DIST_PREP_TAR_COMP: "ghc-aarch64-linux-deb10.tar.xz"
   cache:
-    key: linux-aarch64-deb9
+    key: linux-aarch64-deb10
   tags:
     - aarch64-linux
 
-validate-aarch64-linux-deb9:
-  extends: .build-aarch64-linux-deb9
+validate-aarch64-linux-deb10:
+  extends: .build-aarch64-linux-deb10
   artifacts:
     when: always
     expire_in: 2 week
 
-nightly-aarch64-linux-deb9:
-  extends: .build-aarch64-linux-deb9
-  artifacts:
-    expire_in: 2 year
+nightly-aarch64-linux-deb10:
+  <<: *nightly
+  extends: .build-aarch64-linux-deb10
   variables:
     TEST_TYPE: slowtest
-  only:
-    variables:
-      - $NIGHTLY
 
 #################################
-# armv7-linux-deb9
+# armv7-linux-deb10
 #################################
 
-.build-armv7-linux-deb9:
+.build-armv7-linux-deb10:
   extends: .validate-linux
   stage: full-build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb9:$DOCKER_REV"
-  allow_failure: true
+  image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb10:$DOCKER_REV"
   variables:
-    TEST_ENV: "armv7-linux-deb9"
-    BIN_DIST_PREP_TAR_COMP: "ghc-armv7-linux-deb9.tar.xz"
+    TEST_ENV: "armv7-linux-deb10"
+    BIN_DIST_PREP_TAR_COMP: "ghc-armv7-linux-deb10.tar.xz"
     CONFIGURE_ARGS: "--host=armv7-linux-gnueabihf --build=armv7-linux-gnueabihf --target=armv7-linux-gnueabihf"
   cache:
-    key: linux-armv7-deb9
+    key: linux-armv7-deb10
   tags:
     - armv7-linux
 
-validate-armv7-linux-deb9:
-  extends: .build-armv7-linux-deb9
+validate-armv7-linux-deb10:
+  extends: .build-armv7-linux-deb10
+  allow_failure: true
   artifacts:
     when: always
     expire_in: 2 week
 
-nightly-armv7-linux-deb9:
-  extends: .build-armv7-linux-deb9
-  artifacts:
-    expire_in: 2 year
+nightly-armv7-linux-deb10:
+  <<: *nightly
+  extends: .build-armv7-linux-deb10
   variables:
     TEST_TYPE: slowtest
-  only:
-    variables:
-      - $NIGHTLY
 
 #################################
 # i386-linux-deb9
@@ -514,15 +546,10 @@ validate-i386-linux-deb9:
     expire_in: 2 week
 
 nightly-i386-linux-deb9:
+  <<: *nightly
   extends: .build-i386-linux-deb9
   variables:
     TEST_TYPE: slowtest
-  artifacts:
-    when: always
-    expire_in: 2 week
-  only:
-    variables:
-      - $NIGHTLY
 
 #################################
 # x86_64-linux-deb9
@@ -530,7 +557,6 @@ nightly-i386-linux-deb9:
 
 .build-x86_64-linux-deb9:
   extends: .validate-linux
-  stage: full-build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
   variables:
     TEST_ENV: "x86_64-linux-deb9"
@@ -541,24 +567,27 @@ nightly-i386-linux-deb9:
 # Disabled to reduce CI load
 .validate-x86_64-linux-deb9:
   extends: .build-x86_64-linux-deb9
+  stage: full-build
   artifacts:
     when: always
     expire_in: 2 week
 
+release-x86_64-linux-deb9:
+  <<: *release
+  extends: .build-x86_64-linux-deb9
+  stage: full-build
+
 nightly-x86_64-linux-deb9:
+  <<: *nightly
   extends: .build-x86_64-linux-deb9
-  artifacts:
-    expire_in: 2 year
+  stage: full-build
   variables:
     TEST_TYPE: slowtest
-  only:
-    variables:
-      - $NIGHTLY
 
 # N.B. Has DEBUG assertions enabled in stage2
 validate-x86_64-linux-deb9-debug:
   extends: .build-x86_64-linux-deb9
-  stage: build
+  stage: full-build
   variables:
     BUILD_FLAVOUR: validate
     # Ensure that stage2 also has DEBUG enabled
@@ -567,7 +596,7 @@ validate-x86_64-linux-deb9-debug:
     BUILD_SPHINX_PDF: "YES"
     TEST_TYPE: slowtest
     TEST_ENV: "x86_64-linux-deb9-debug"
-    BIN_DIST_PREP_COMP: "ghc-x86_64-deb9-linux-debug.tar.xz"
+    BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux-debug.tar.xz"
   artifacts:
     when: always
     expire_in: 2 week
@@ -581,87 +610,142 @@ validate-x86_64-linux-deb9-debug:
     TEST_ENV: "x86_64-linux-deb9-llvm"
 
 nightly-x86_64-linux-deb9-llvm:
+  <<: *nightly
   extends: .build-x86_64-linux-deb9
   stage: full-build
   variables:
     BUILD_FLAVOUR: perf-llvm
     TEST_ENV: "x86_64-linux-deb9-llvm"
-  only:
-    variables:
-      - $NIGHTLY
 
 validate-x86_64-linux-deb9-integer-simple:
   extends: .build-x86_64-linux-deb9
   stage: full-build
   variables:
+    BUILD_FLAVOUR: validate
     INTEGER_LIBRARY: integer-simple
-    TEST_ENV: "x86_64-linux-deb9-integer-simple"
+    TEST_ENV: "x86_64-linux-deb9-integer-simple-validate"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux-integer-simple.tar.xz"
 
 nightly-x86_64-linux-deb9-integer-simple:
+  <<: *nightly
   extends: .build-x86_64-linux-deb9
   stage: full-build
   variables:
     INTEGER_LIBRARY: integer-simple
     TEST_ENV: "x86_64-linux-deb9-integer-simple"
     TEST_TYPE: slowtest
-  artifacts:
-    expire_in: 2 year
-  only:
-    variables:
-      - $NIGHTLY
 
-release-x86_64-linux-deb9-dwarf:
-  extends: .validate-linux
-  stage: build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
+.build-x86_64-linux-deb9-tsan:
+  extends: .validate-linux-hadrian
+  stage: full-build
+  variables:
+    TEST_ENV: "x86_64-linux-deb9-tsan"
+    BUILD_FLAVOUR: "thread-sanitizer"
+    TSAN_OPTIONS: "suppressions=$CI_PROJECT_DIR/rts/.tsan-suppressions"
+    # Haddock is large enough to make TSAN choke without massive quantities of
+    # memory.
+    HADRIAN_ARGS: "--docs=none"
+
+nightly-x86_64-linux-deb9-tsan:
+  <<: *nightly
+  extends: .build-x86_64-linux-deb9-tsan
+
+validate-x86_64-linux-deb9-tsan:
+  extends: .build-x86_64-linux-deb9-tsan
+  when: manual
+
+validate-x86_64-linux-deb9-dwarf:
+  extends: .build-x86_64-linux-deb9
+  stage: full-build
   variables:
     CONFIGURE_ARGS: "--enable-dwarf-unwind"
     BUILD_FLAVOUR: dwarf
     TEST_ENV: "x86_64-linux-deb9-dwarf"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux-dwarf.tar.xz"
-  artifacts:
-    when: always
-    expire_in: 2 week
+
+#################################
+# x86_64-linux-deb10
+#################################
+
+.build-x86_64-linux-deb10:
+  extends: .validate-linux
+  stage: full-build
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV"
+  variables:
+    TEST_ENV: "x86_64-linux-deb10"
+    BIN_DIST_PREP_TAR_COMP: "./ghc-x86_64-deb10-linux.tar.xz"
+    LD: "ld.gold"
   cache:
-    key: linux-x86_64-deb9
+    key: linux-x86_64-deb10
+
+# Disabled to alleviate CI load
+.validate-x86_64-linux-deb10:
+  extends: .build-x86_64-linux-deb10
+  stage: full-build
+
+nightly-x86_64-linux-deb10:
+  <<: *nightly
+  extends: .build-x86_64-linux-deb10
+  variables:
+    TEST_TYPE: slowtest
 
+release-x86_64-linux-deb10:
+  <<: *release
+  extends: .build-x86_64-linux-deb10
+
+release-x86_64-linux-deb10-dwarf:
+  <<: *release
+  extends: .build-x86_64-linux-deb10
+  variables:
+    CONFIGURE_ARGS: "--enable-dwarf-unwind"
+    BUILD_FLAVOUR: dwarf
+    TEST_ENV: "x86_64-linux-deb10-dwarf"
+    BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb10-linux-dwarf.tar.xz"
 
 #################################
 # x86_64-linux-deb8
 #################################
 
-release-x86_64-linux-deb8:
+.build-x86_64-linux-deb8:
   extends: .validate-linux
   stage: full-build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb8:$DOCKER_REV"
+  allow_failure: true
   variables:
     TEST_ENV: "x86_64-linux-deb8"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb8-linux.tar.xz"
-  only:
-    - tags
+    # Debian 8's Sphinx is too old to support the table directive's :widths:
+    # option: https://sourceforge.net/p/docutils/patches/120/
+    BUILD_SPHINX_HTML: "NO"
+    BUILD_SPHINX_INFO: "NO"
+    BUILD_SPHINX_PDF: "NO"
+    BUILD_SPHINX_MAN: "NO"
   cache:
     key: linux-x86_64-deb8
-  artifacts:
-    when: always
-    expire_in: 2 week
+
+release-x86_64-linux-deb8:
+  <<: *release
+  extends: .build-x86_64-linux-deb8
 
 #################################
 # x86_64-linux-alpine
 #################################
 
-.build-x86_64-linux-alpine:
-  extends: .validate-linux
+.build-x86_64-linux-alpine-hadrian:
+  extends: .validate-linux-hadrian
   stage: full-build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine:$DOCKER_REV"
   # There are currently a few failing tests
   allow_failure: true
   variables:
-    BUILD_SPHINX_PDF: "NO"
     TEST_ENV: "x86_64-linux-alpine"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-alpine-linux.tar.xz"
     # Can't use ld.gold due to #13958.
     CONFIGURE_ARGS: "--disable-ld-override"
+    HADRIAN_ARGS: "--docs=no-sphinx"
+    # encoding004 due to lack of locale support
+    # T10458 due to fact that dynamic linker tries to reload libAS
+    BROKEN_TESTS: "encoding004 T10458"
   cache:
     key: linux-x86_64-alpine
   artifacts:
@@ -669,21 +753,18 @@ release-x86_64-linux-deb8:
     expire_in: 2 week
 
 release-x86_64-linux-alpine:
-  extends: .build-x86_64-linux-alpine
-  only:
-    - tags
+  <<: *release
+  extends: .build-x86_64-linux-alpine-hadrian
 
 nightly-x86_64-linux-alpine:
-  extends: .build-x86_64-linux-alpine
-  only:
-    variables:
-      - $NIGHTLY
+  <<: *nightly
+  extends: .build-x86_64-linux-alpine-hadrian
 
 #################################
 # x86_64-linux-centos7
 #################################
 
-release-x86_64-linux-centos7:
+.build-x86_64-linux-centos7:
   extends: .validate-linux
   stage: full-build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-centos7:$DOCKER_REV"
@@ -693,19 +774,20 @@ release-x86_64-linux-centos7:
     BUILD_SPHINX_PDF: "NO"
     TEST_ENV: "x86_64-linux-centos7"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-centos7-linux.tar.xz"
-  only:
-    - tags
+    # CentOS seems to default to ascii
+    LANG: "en_US.UTF-8"
   cache:
     key: linux-x86_64-centos7
-  artifacts:
-    when: always
-    expire_in: 2 week
+
+release-x86_64-linux-centos7:
+  <<: *release
+  extends: .build-x86_64-linux-centos7
 
 #################################
 # x86_64-linux-fedora27
 #################################
 
-validate-x86_64-linux-fedora27:
+.build-x86_64-linux-fedora27:
   extends: .validate-linux
   stage: full-build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora27:$DOCKER_REV"
@@ -714,9 +796,27 @@ validate-x86_64-linux-fedora27:
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-fedora27-linux.tar.xz"
   cache:
     key: linux-x86_64-fedora27
+
+validate-x86_64-linux-fedora27:
+  extends: .build-x86_64-linux-fedora27
   artifacts:
     when: always
-    expire_in: 2 week
+    # These are used for head.hackage jobs therefore we keep them around for
+    # longer.
+    expire_in: 8 week
+
+release-x86_64-linux-fedora27:
+  <<: *release
+  extends: .build-x86_64-linux-fedora27
+
+release-x86_64-linux-fedora27-dwarf:
+  <<: *release
+  extends: .build-x86_64-linux-fedora27
+  variables:
+    CONFIGURE_ARGS: "--enable-dwarf-unwind"
+    BUILD_FLAVOUR: dwarf
+    TEST_ENV: "x86_64-linux-fedora27-dwarf"
+    BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-fedora27-linux-dwarf.tar.xz"
 
 ############################################################
 # Validation via Pipelines (Windows)
@@ -724,58 +824,49 @@ validate-x86_64-linux-fedora27:
 
 .build-windows:
   <<: *only-default
+  # For the reasons given in #17777 this build isn't reliable.
+  allow_failure: true
   before_script:
     - git clean -xdf
-    - git submodule foreach git clean -xdf
 
-    # Use a local temporary directory to ensure that concurrent builds don't
-    # interfere with one another
-    - |
-      mkdir tmp
-      set TMP=%cd%\tmp
-      set TEMP=%cd%\tmp
-
-    - set PATH=C:\msys64\usr\bin;%PATH%
-    - git submodule sync --recursive
-    - git submodule update --init --recursive
-    - git checkout .gitmodules
-    - "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
-    - bash .gitlab/win32-init.sh
+    # Setup toolchain
+    - bash .gitlab/ci.sh setup
   after_script:
-    - rd /s /q tmp
-    - robocopy /np /nfl /ndl /e "%APPDATA%\cabal" cabal-cache
-    - bash -c 'make clean || true'
+    - |
+      Copy-Item -Recurse -Path $Env:APPDATA\cabal -Destination cabal-cache
+    - bash .gitlab/ci.sh clean
   dependencies: []
   variables:
-    FORCE_SYMLINKS: 1
+    #FORCE_SYMLINKS: 1
     LANG: "en_US.UTF-8"
     SPHINXBUILD: "/mingw64/bin/sphinx-build.exe"
+    CABAL_INSTALL_VERSION: 3.0.0.0
+    GHC_VERSION: "8.8.3"
   cache:
     paths:
       - cabal-cache
-      - ghc-8.6.5
+      - toolchain
       - ghc-tarballs
 
 .build-windows-hadrian:
   extends: .build-windows
   stage: full-build
   variables:
-    GHC_VERSION: "8.6.5"
     FLAVOUR: "validate"
+    # skipping perf tests for now since we build a quick-flavoured GHC,
+    # which might result in some broken perf tests?
+    HADRIAN_ARGS: "--docs=no-sphinx --skip-perf"
+
   # due to #16574 this currently fails
   allow_failure: true
+
   script:
-    - |
-      python boot
-      bash -c './configure --enable-tarballs-autodownload GHC=`pwd`/toolchain/bin/ghc HAPPY=`pwd`/toolchain/bin/happy ALEX=`pwd`/toolchain/bin/alex'
-    - bash -c "PATH=`pwd`/toolchain/bin:$PATH hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --flavour=Quick --docs=no-sphinx binary-dist"
-    - mv _build/bindist/ghc*.tar.xz ghc.tar.xz
-    - bash -c "export TOP=$(pwd); cd _build/bindist/ghc-*/ && PATH=$TOP/toolchain/bin:$PATH ./configure --prefix=$TOP/_build/install && make install && cd ../../../"
-    - bash -c "export TOP=$(pwd); PATH=$TOP/toolchain/bin:$PATH hadrian/build.cabal.sh --flavour=$FLAVOUR -j`mk/detect-cpu-count.sh` --flavour=quick test --summary-junit=./junit.xml --skip-perf --test-compiler=$TOP/_build/install/bin/ghc"
-    # skipping perf tests for now since we build a quick-flavoured GHC,
-    # which might result in some broken perf tests?
+    - bash .gitlab/ci.sh configure
+    - bash .gitlab/ci.sh build_hadrian
+    - bash .gitlab/ci.sh test_hadrian
   tags:
-    - x86_64-windows
+    - new-x86_64-windows
+    - test
   artifacts:
     reports:
       junit: junit.xml
@@ -794,106 +885,98 @@ validate-x86_64-windows-hadrian:
     key: "x86_64-windows-hadrian-$WINDOWS_TOOLCHAIN_VERSION"
 
 nightly-i386-windows-hadrian:
+  <<: *nightly
   extends: .build-windows-hadrian
   variables:
     MSYSTEM: MINGW32
     TEST_ENV: "i386-windows-hadrian"
-  only:
-    variables:
-      - $NIGHTLY
   cache:
     key: "i386-windows-hadrian-$WINDOWS_TOOLCHAIN_VERSION"
 
 .build-windows-make:
   extends: .build-windows
   stage: full-build
-  allow_failure: true
   variables:
     BUILD_FLAVOUR: "quick"
-    GHC_VERSION: "8.6.5"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-mingw32.tar.xz"
   script:
-    - |
-      python boot
-      bash -c './configure --enable-tarballs-autodownload GHC=`pwd`/toolchain/bin/ghc HAPPY=`pwd`/toolchain/bin/happy ALEX=`pwd`/toolchain/bin/alex $CONFIGURE_ARGS'
-    - bash -c "echo include mk/flavours/${BUILD_FLAVOUR}.mk > mk/build.mk"
-    - bash -c "echo 'GhcLibHcOpts+=-haddock' >> mk/build.mk"
-    - bash -c "PATH=`pwd`/toolchain/bin:$PATH make -j`mk/detect-cpu-count.sh`"
-    - bash -c "PATH=`pwd`/toolchain/bin:$PATH make binary-dist-prep TAR_COMP_OPTS=-1"
-    - bash -c "PATH=`pwd`/toolchain/bin:$PATH make test_bindist TEST_PREP=YES"
-    - bash -c 'make V=0 test THREADS=`mk/detect-cpu-count.sh` JUNIT_FILE=../../junit.xml'
+    - bash .gitlab/ci.sh configure
+    - bash .gitlab/ci.sh build_make
+    - bash .gitlab/ci.sh test_make
   tags:
-    - x86_64-windows
+    - new-x86_64-windows
+    - test
   artifacts:
     when: always
     expire_in: 2 week
     reports:
       junit: junit.xml
     paths:
-      - $BIN_DIST_PREP_TAR_COMP
+      # N.B. variable interpolation apparently doesn't work on Windows so
+      # this can't be $BIN_DIST_PREP_TAR_COMP
+      - "ghc-x86_64-mingw32.tar.xz"
       - junit.xml
 
-validate-x86_64-windows:
+.build-x86_64-windows-make:
   extends: .build-windows-make
   variables:
     MSYSTEM: MINGW64
-    CONFIGURE_ARGS: "--target=x86_64-unknown-mingw32"
     TEST_ENV: "x86_64-windows"
   cache:
     key: "x86_64-windows-$WINDOWS_TOOLCHAIN_VERSION"
 
+validate-x86_64-windows:
+  extends: .build-x86_64-windows-make
+
 nightly-x86_64-windows:
-  extends: .build-windows-make
+  <<: *nightly
+  extends: .build-x86_64-windows-make
   stage: full-build
   variables:
     BUILD_FLAVOUR: "validate"
-    MSYSTEM: MINGW64
-    CONFIGURE_ARGS: "--target=x86_64-unknown-mingw32"
-  only:
-    variables:
-      - $NIGHTLY
-  cache:
-    key: "x86_64-windows-$WINDOWS_TOOLCHAIN_VERSION"
 
 # Normal Windows validate builds are profiled; that won't do for releases.
 release-x86_64-windows:
+  <<: *release
   extends: validate-x86_64-windows
   variables:
-    MSYSTEM: MINGW64
     BUILD_FLAVOUR: "perf"
-    CONFIGURE_ARGS: "--target=x86_64-unknown-mingw32"
-    TEST_ENV: "x86_64-windows"
-  only:
-    - tags
-
-release-i386-windows:
-  extends: .build-windows-make
-  only:
-    - tags
+    #
+release-x86_64-windows-integer-simple:
+  <<: *release
+  extends: validate-x86_64-windows
   variables:
-    MSYSTEM: MINGW32
+    INTEGER_LIBRARY: integer-simple
     BUILD_FLAVOUR: "perf"
-    CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
-    # Due to #15934
-    BUILD_PROF_LIBS: "NO"
-    TEST_ENV: "i386-windows"
-  cache:
-    key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
 
-nightly-i386-windows:
+
+.build-i386-windows-make:
   extends: .build-windows-make
-  only:
-    variables:
-      - $NIGHTLY
   variables:
     MSYSTEM: MINGW32
-    CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
     # Due to #15934
     BUILD_PROF_LIBS: "NO"
     TEST_ENV: "i386-windows"
+  # Due to #17736
+  allow_failure: true
   cache:
     key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
 
+validate-i386-windows:
+  extends: .build-i386-windows-make
+  variables:
+    BUILD_FLAVOUR: "perf"
+
+release-i386-windows:
+  <<: *release
+  extends: .build-i386-windows-make
+  variables:
+    BUILD_FLAVOUR: "perf"
+
+nightly-i386-windows:
+  <<: *nightly
+  extends: .build-i386-windows-make
+
 ############################################################
 # Cleanup
 ############################################################
@@ -948,7 +1031,7 @@ doc-tarball:
     - validate-x86_64-linux-deb9-debug
     - validate-x86_64-windows
   variables:
-    LINUX_BINDIST: "ghc-x86_64-deb9-linux.tar.xz"
+    LINUX_BINDIST: "ghc-x86_64-deb9-linux-debug.tar.xz"
     WINDOWS_BINDIST: "ghc-x86_64-mingw32.tar.xz"
   # Due to Windows allow_failure
   allow_failure: true
@@ -979,6 +1062,7 @@ source-tarball:
   tags:
     - x86_64-linux
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
+  when: always
   dependencies: []
   only:
     - tags
@@ -987,7 +1071,7 @@ source-tarball:
       - ghc-*.tar.xz
       - version
   script:
-    - mk/get-win32-tarballs.sh download all
+    - python3 mk/get-win32-tarballs.py download all
     - ./boot
     - ./configure
     - make sdist
@@ -1030,10 +1114,8 @@ hackage-label:
       - $CI_MERGE_REQUEST_LABELS =~ /.*user-facing.*/
 
 nightly-hackage:
+  <<: *nightly
   extends: .hackage
-  only:
-    variables:
-      - $NIGHTLY
 
 ############################################################
 # Nofib testing
@@ -1042,7 +1124,7 @@ nightly-hackage:
 perf-nofib:
   stage: testing
   dependencies:
-    - release-x86_64-linux-deb9-dwarf
+    - validate-x86_64-linux-deb9-dwarf
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
   only:
     refs:

.gitlab/ci.sh

+#!/usr/bin/env bash
+# shellcheck disable=SC2230
+
+# This is the primary driver of the GitLab CI infrastructure.
+
+set -e -o pipefail
+
+# Configuration:
+hackage_index_state="@1579718451"
+
+# Colors
+BLACK="0;30"
+GRAY="1;30"
+RED="0;31"
+LT_RED="1;31"
+BROWN="0;33"
+LT_BROWN="1;33"
+GREEN="0;32"
+LT_GREEN="1;32"
+BLUE="0;34"
+LT_BLUE="1;34"
+PURPLE="0;35"
+LT_PURPLE="1;35"
+CYAN="0;36"
+LT_CYAN="1;36"
+WHITE="1;37"
+LT_GRAY="0;37"
+
+# GitLab Pipelines log section delimiters
+# https://gitlab.com/gitlab-org/gitlab-foss/issues/14664
+start_section() {
+  name="$1"
+  echo -e "section_start:$(date +%s):$name\015\033[0K"
+}
+
+end_section() {
+  name="$1"
+  echo -e "section_end:$(date +%s):$name\015\033[0K"
+}
+
+echo_color() {
+  local color="$1"
+  local msg="$2"
+  echo -e "\033[${color}m${msg}\033[0m"
+}
+
+error() { echo_color "${RED}" "$1"; }
+warn() { echo_color "${LT_BROWN}" "$1"; }
+info() { echo_color "${LT_BLUE}" "$1"; }
+
+fail() { error "error: $1"; exit 1; }
+
+function run() {
+  info "Running $*..."
+  "$@" || ( error "$* failed"; return 1; )
+}
+
+TOP="$(pwd)"
+
+function mingw_init() {
+  case "$MSYSTEM" in
+    MINGW32)
+      triple="i386-unknown-mingw32"
+      boot_triple="i386-unknown-mingw32" # triple of bootstrap GHC
+      ;;
+    MINGW64)
+      triple="x86_64-unknown-mingw32"
+      boot_triple="x86_64-unknown-mingw32" # triple of bootstrap GHC
+      ;;
+    *)
+      fail "win32-init: Unknown MSYSTEM $MSYSTEM"
+      ;;
+  esac
+
+  # Bring mingw toolchain into PATH.
+  # This is extracted from /etc/profile since this script inexplicably fails to
+  # run under gitlab-runner.
+  # shellcheck disable=SC1091
+  source /etc/msystem
+  MINGW_MOUNT_POINT="${MINGW_PREFIX}"
+  PATH="$MINGW_MOUNT_POINT/bin:$PATH"
+
+  # We always use mingw64 Python to avoid path length issues like #17483.
+  export PYTHON="/mingw64/bin/python3"
+}
+
+# This will contain GHC's local native toolchain
+toolchain="$TOP/toolchain"
+mkdir -p "$toolchain/bin"
+PATH="$toolchain/bin:$PATH"
+
+export METRICS_FILE="$CI_PROJECT_DIR/performance-metrics.tsv"
+
+cores="$(mk/detect-cpu-count.sh)"
+
+# Use a local temporary directory to ensure that concurrent builds don't
+# interfere with one another
+mkdir -p "$TOP/tmp"
+export TMP="$TOP/tmp"
+export TEMP="$TOP/tmp"
+
+function darwin_setup() {
+  # It looks like we already have python2 here and just installing python3
+  # does not work.
+  brew upgrade python
+  brew install ghc cabal-install ncurses gmp
+
+  pip3 install sphinx
+  # PDF documentation disabled as MacTeX apparently doesn't include xelatex.
+  #brew cask install mactex
+}
+
+function show_tool() {
+  local tool="$1"
+  info "$tool = ${!tool}"
+  ${!tool} --version
+}
+
+function set_toolchain_paths() {
+  needs_toolchain=1
+  case "$(uname)" in
+    Linux) needs_toolchain="" ;;
+    *) ;;
+  esac
+
+  if [[ -n "$needs_toolchain" ]]; then
+      # These are populated by setup_toolchain
+      GHC="$toolchain/bin/ghc$exe"
+      CABAL="$toolchain/bin/cabal$exe"
+      HAPPY="$toolchain/bin/happy$exe"
+      ALEX="$toolchain/bin/alex$exe"
+  else
+      GHC="$(which ghc)"
+      CABAL="/usr/local/bin/cabal"
+      HAPPY="$HOME/.cabal/bin/happy"
+      ALEX="$HOME/.cabal/bin/alex"
+  fi
+  export GHC
+  export CABAL
+  export HAPPY
+  export ALEX
+
+  # FIXME: Temporarily use ghc from ports
+  case "$(uname)" in
+    FreeBSD) GHC="/usr/local/bin/ghc" ;;
+    *) ;;
+  esac
+}
+
+# Extract GHC toolchain
+function setup() {
+  if [ -d "$TOP/cabal-cache" ]; then
+      info "Extracting cabal cache..."
+      mkdir -p "$cabal_dir"
+      cp -Rf cabal-cache/* "$cabal_dir"
+  fi
+
+  if [[ -n "$needs_toolchain" ]]; then
+    setup_toolchain
+  fi
+  case "$(uname)" in
+    Darwin) darwin_setup ;;
+    *) ;;
+  esac
+
+  # Make sure that git works
+  git config user.email "ghc-ci@gitlab-haskell.org"
+  git config user.name "GHC GitLab CI"
+
+  info "====================================================="
+  info "Toolchain versions"
+  info "====================================================="
+  show_tool GHC
+  show_tool CABAL
+  show_tool HAPPY
+  show_tool ALEX
+}
+
+function fetch_ghc() {
+  local v="$GHC_VERSION"
+  if [[ -z "$v" ]]; then
+      fail "GHC_VERSION is not set"
+  fi
+
+  if [ ! -e "$GHC" ]; then
+      start_section "fetch GHC"
+      url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot_triple}.tar.xz"
+      info "Fetching GHC binary distribution from $url..."
+      curl "$url" > ghc.tar.xz || fail "failed to fetch GHC binary distribution"
+      tar -xJf ghc.tar.xz || fail "failed to extract GHC binary distribution"
+      case "$(uname)" in
+        MSYS_*|MINGW*)
+          cp -r "ghc-${GHC_VERSION}"/* "$toolchain"
+          ;;
+        *)
+          pushd "ghc-${GHC_VERSION}"
+          ./configure --prefix="$toolchain"
+          "$MAKE" install
+          popd
+          ;;
+      esac
+      rm -Rf "ghc-${GHC_VERSION}" ghc.tar.xz
+      end_section "fetch GHC"
+  fi
+
+}
+
+function fetch_cabal() {
+  local v="$CABAL_INSTALL_VERSION"
+  if [[ -z "$v" ]]; then
+      fail "CABAL_INSTALL_VERSION is not set"
+  fi
+
+  if [ ! -e "$CABAL" ]; then
+      start_section "fetch GHC"
+      case "$(uname)" in
+        # N.B. Windows uses zip whereas all others use .tar.xz
+        MSYS_*|MINGW*)
+          case "$MSYSTEM" in
+            MINGW32) cabal_arch="i386" ;;
+            MINGW64) cabal_arch="x86_64" ;;
+            *) fail "unknown MSYSTEM $MSYSTEM" ;;
+          esac
+          url="https://downloads.haskell.org/~cabal/cabal-install-$v/cabal-install-$v-$cabal_arch-unknown-mingw32.zip"
+          info "Fetching cabal binary distribution from $url..."
+          curl "$url" > "$TMP/cabal.zip"
+          unzip "$TMP/cabal.zip"
+          mv cabal.exe "$CABAL"
+          ;;
+        *)
+          local base_url="https://downloads.haskell.org/~cabal/cabal-install-$v/"
+          case "$(uname)" in
+            Darwin) cabal_url="$base_url/cabal-install-$v-x86_64-apple-darwin17.7.0.tar.xz" ;;
+            FreeBSD)
+              #cabal_url="$base_url/cabal-install-$v-x86_64-portbld-freebsd.tar.xz" ;;
+              cabal_url="http://home.smart-cactus.org/~ben/ghc/cabal-install-3.0.0.0-x86_64-portbld-freebsd.tar.xz" ;;
+            *) fail "don't know where to fetch cabal-install for $(uname)"
+          esac
+          echo "Fetching cabal-install from $cabal_url"
+          curl "$cabal_url" > cabal.tar.xz
+          tar -xJf cabal.tar.xz
+          mv cabal "$toolchain/bin"
+          ;;
+      esac
+      end_section "fetch GHC"
+  fi
+}
+
+# For non-Docker platforms we prepare the bootstrap toolchain
+# here. For Docker platforms this is done in the Docker image
+# build.
+function setup_toolchain() {
+  fetch_ghc
+  fetch_cabal
+  cabal_install="$CABAL v2-install --index-state=$hackage_index_state --installdir=$toolchain/bin"
+  # Avoid symlinks on Windows
+  case "$(uname)" in
+    MSYS_*|MINGW*) cabal_install="$cabal_install --install-method=copy" ;;
+    *) ;;
+  esac
+
+  if [ ! -e "$HAPPY" ]; then
+      info "Building happy..."
+      cabal update
+      $cabal_install happy
+  fi
+
+  if [ ! -e "$ALEX" ]; then
+      info "Building alex..."
+      cabal update
+      $cabal_install alex
+  fi
+}
+
+function cleanup_submodules() {
+  start_section "clean submodules"
+  info "Cleaning submodules..."
+  # On Windows submodules can inexplicably get into funky states where git
+  # believes that the submodule is initialized yet its associated repository
+  # is not valid. Avoid failing in this case with the following insanity.
+  git submodule sync --recursive || git submodule deinit --force --all
+  git submodule update --init --recursive
+  git submodule foreach git clean -xdf
+  end_section "clean submodules"
+}
+
+function prepare_build_mk() {
+  if [[ -z "$BUILD_FLAVOUR" ]]; then fail "BUILD_FLAVOUR is not set"; fi
+  if [[ -z ${BUILD_SPHINX_HTML:-} ]]; then BUILD_SPHINX_HTML=YES; fi
+  if [[ -z ${BUILD_SPHINX_PDF:-} ]]; then BUILD_SPHINX_PDF=YES; fi
+  if [[ -z ${INTEGER_LIBRARY:-} ]]; then INTEGER_LIBRARY=integer-gmp; fi
+
+  cat > mk/build.mk <<EOF
+V=1
+HADDOCK_DOCS=YES
+LATEX_DOCS=YES
+HSCOLOUR_SRCS=YES
+BUILD_SPHINX_HTML=$BUILD_SPHINX_HTML
+BUILD_SPHINX_PDF=$BUILD_SPHINX_PDF
+BeConservative=YES
+INTEGER_LIBRARY=$INTEGER_LIBRARY
+XZ_CMD=$XZ
+
+BuildFlavour=$BUILD_FLAVOUR
+ifneq "\$(BuildFlavour)" ""
+include mk/flavours/\$(BuildFlavour).mk
+endif
+GhcLibHcOpts+=-haddock
+EOF
+
+  if [ -n "$HADDOCK_HYPERLINKED_SOURCES" ]; then
+    echo "EXTRA_HADDOCK_OPTS += --hyperlinked-source --quickjump" >> mk/build.mk
+  fi
+
+  case "$(uname)" in
+    Darwin) echo "libraries/integer-gmp_CONFIGURE_OPTS += --configure-option=--with-intree-gmp" >> mk/build.mk ;;
+    *) ;;
+  esac
+
+  info "build.mk is:"
+  cat mk/build.mk
+}
+
+function configure() {
+  start_section "booting"
+  run python3 boot
+  end_section "booting"
+
+  local target_args=""
+  if [[ -n "$triple" ]]; then
+    target_args="--target=$triple"
+  fi
+
+  start_section "configuring"
+  run ./configure \
+    --enable-tarballs-autodownload \
+    $target_args \
+    $CONFIGURE_ARGS \
+    GHC="$GHC" \
+    HAPPY="$HAPPY" \
+    ALEX="$ALEX" \
+    || ( cat config.log; fail "configure failed" )
+  end_section "configuring"
+}
+
+function build_make() {
+  prepare_build_mk
+  if [[ -z "$BIN_DIST_PREP_TAR_COMP" ]]; then
+    fail "BIN_DIST_PREP_TAR_COMP is not set"
+  fi
+  if [[ -n "$VERBOSE" ]]; then
+    MAKE_ARGS="$MAKE_ARGS V=1"
+  else
+    MAKE_ARGS="$MAKE_ARGS V=0"
+  fi
+
+  echo "include mk/flavours/${BUILD_FLAVOUR}.mk" > mk/build.mk
+  echo 'GhcLibHcOpts+=-haddock' >> mk/build.mk
+  run "$MAKE" -j"$cores" $MAKE_ARGS
+  run "$MAKE" -j"$cores" binary-dist-prep TAR_COMP_OPTS=-1
+  ls -lh "$BIN_DIST_PREP_TAR_COMP"
+}
+
+function fetch_perf_notes() {
+  info "Fetching perf notes..."
+  "$TOP/.gitlab/test-metrics.sh" pull
+}
+
+function push_perf_notes() {
+  info "Pushing perf notes..."
+  "$TOP/.gitlab/test-metrics.sh" push
+}
+
+function test_make() {
+  run "$MAKE" test_bindist TEST_PREP=YES
+  run "$MAKE" V=0 test \
+    THREADS="$cores" \
+    JUNIT_FILE=../../junit.xml
+}
+
+function build_hadrian() {
+  if [ -z "$FLAVOUR" ]; then
+    fail "FLAVOUR not set"
+  fi
+
+  run_hadrian binary-dist
+
+  mv _build/bindist/ghc*.tar.xz ghc.tar.xz
+}
+
+function test_hadrian() {
+  cd _build/bindist/ghc-*/
+  run ./configure --prefix="$TOP"/_build/install
+  run "$MAKE" install
+  cd ../../../
+
+  run_hadrian \
+    test \
+    --summary-junit=./junit.xml \
+    --test-compiler="$TOP"/_build/install/bin/ghc
+}
+
+function clean() {
+  rm -R tmp
+  run "$MAKE" --quiet clean || true
+  run rm -Rf _build
+}
+
+function run_hadrian() {
+  if [ -n "$VERBOSE" ]; then HADRIAN_ARGS="$HADRIAN_ARGS -V"; fi
+  run hadrian/build.cabal.sh \
+    --flavour="$FLAVOUR" \
+    -j"$cores" \
+    $HADRIAN_ARGS \
+    $@
+}
+
+# A convenience function to allow debugging in the CI environment.
+function shell() {
+  local cmd=$@
+  if [ -z "$cmd" ]; then
+    cmd="bash -i"
+  fi
+  run $cmd
+}
+
+# Determine Cabal data directory
+case "$(uname)" in
+  MSYS_*|MINGW*) exe=".exe"; cabal_dir="$APPDATA/cabal" ;;
+  *) cabal_dir="$HOME/.cabal"; exe="" ;;
+esac
+
+# Platform-specific environment initialization
+MAKE="make"
+case "$(uname)" in
+  MSYS_*|MINGW*) mingw_init ;;
+  Darwin) boot_triple="x86_64-apple-darwin" ;;
+  FreeBSD)
+    boot_triple="x86_64-portbld-freebsd"
+    MAKE="gmake"
+    ;;
+  Linux) ;;
+  *) fail "uname $(uname) is not supported" ;;
+esac
+
+set_toolchain_paths
+
+case $1 in
+  setup) setup && cleanup_submodules ;;
+  configure) configure ;;
+  build_make) build_make ;;
+  test_make) fetch_perf_notes; test_make; push_perf_notes ;;
+  build_hadrian) build_hadrian ;;
+  test_hadrian) fetch_perf_notes; test_hadrian; push_perf_notes ;;
+  run_hadrian) run_hadrian $@ ;;
+  clean) clean ;;
+  shell) shell $@ ;;
+  *) fail "unknown mode $1" ;;
+esac

.gitlab/prepare-system.sh

-#!/usr/bin/env bash
-# vim: sw=2 et
-set -euo pipefail
-
-fail() {
-  echo "ERROR: $*" >&2
-  exit 1
-}
-
-hackage_index_state="@1522046735"
-
-if [[ -z ${BUILD_SPHINX_HTML:-} ]]; then BUILD_SPHINX_HTML=YES; fi
-if [[ -z ${BUILD_SPHINX_PDF:-} ]]; then BUILD_SPHINX_PDF=YES; fi
-if [[ -z ${INTEGER_LIBRARY:-} ]]; then INTEGER_LIBRARY=integer-gmp; fi
-if [[ -z ${BUILD_FLAVOUR:-} ]]; then BUILD_FLAVOUR=perf; fi
-
-cat > mk/build.mk <<EOF
-V=1
-HADDOCK_DOCS=YES
-LATEX_DOCS=YES
-HSCOLOUR_SRCS=YES
-BUILD_SPHINX_HTML=$BUILD_SPHINX_HTML
-BUILD_SPHINX_PDF=$BUILD_SPHINX_PDF
-BeConservative=YES
-INTEGER_LIBRARY=$INTEGER_LIBRARY
-XZ_CMD=pxz
-EOF
-
-cat <<EOF >> mk/build.mk
-BuildFlavour=$BUILD_FLAVOUR
-ifneq "\$(BuildFlavour)" ""
-include mk/flavours/\$(BuildFlavour).mk
-endif
-GhcLibHcOpts+=-haddock
-EOF
-
-case "$(uname)" in
-  Linux)
-    if [[ -n ${TARGET:-} ]]; then
-      if [[ $TARGET = FreeBSD ]]; then
-        # cross-compiling to FreeBSD
-        echo 'HADDOCK_DOCS = NO' >> mk/build.mk
-        echo 'WERROR=' >> mk/build.mk
-        # https://circleci.com/docs/2.0/env-vars/#interpolating-environment-variables-to-set-other-environment-variables
-        echo 'export PATH=/opt/ghc/bin:$PATH' >> $BASH_ENV
-      else
-        fail "TARGET=$target not supported"
-      fi
-    fi
-    ;;
-
-  Darwin)
-    if [[ -n ${TARGET:-} ]]; then
-      fail "uname=$(uname) not supported for cross-compilation"
-    fi
-    # It looks like we already have python2 here and just installing python3
-    # does not work.
-    brew upgrade python
-    brew install ghc cabal-install ncurses gmp
-
-    pip3 install sphinx
-    # PDF documentation disabled as MacTeX apparently doesn't include xelatex.
-    #brew cask install mactex
-
-    cabal update
-    cabal install --reinstall alex happy haddock hscolour --index-state=$hackage_index_state
-    # put them on the $PATH, don't fail if already installed
-    ln -s $HOME/.cabal/bin/alex /usr/local/bin/alex || true
-    ln -s $HOME/.cabal/bin/happy /usr/local/bin/happy || true
-    ln -s $HOME/.cabal/bin/HsColour /usr/local/bin/HsColour || true
-    echo "libraries/integer-gmp_CONFIGURE_OPTS += --configure-option=--with-intree-gmp" >> mk/build.mk
-    ;;
-  *)
-    fail "uname=$(uname) not supported"
-esac
-
-echo "================================================="
-echo "Build.mk:"
-echo ""
-cat mk/build.mk
-echo "================================================="

.gitlab/test-metrics.sh

+#!/usr/bin/env bash
+# vim: sw=2 et
+set -euo pipefail
+
+NOTES_ORIGIN="https://gitlab.haskell.org/ghc/ghc-performance-notes.git"
+NOTES_ORIGIN_PUSH="git@gitlab.haskell.org:ghc/ghc-performance-notes.git"
+REF="perf"
+
+run() {
+  echo "$@"
+  $@
+}
+
+fail() {
+  echo "ERROR: $*" >&2
+  exit 1
+}
+
+function pull() {
+  local ref="refs/notes/$REF"
+  run git fetch -f $NOTES_ORIGIN $ref:$ref
+  echo "perf notes ref $ref is $(git rev-parse $ref)"
+}
+
+function setup_ssh() {
+  # Add gitlab as a known host.
+  mkdir -p ~/.ssh
+  echo "|1|+AUrMGS1elvPeLNt+NHGa5+c6pU=|4XvfRsQftO1OgZD4c0JJ7oNaii8= ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDXilA5l4kOZPx0nM6xDATF+t4fS6te0eYPDwBI/jLWD9cJVtCnsrwMl5ar+/NfmcD0jnCYztUiVHuXyTaWPJYSQpwltfpTeqpo9/z/0MxkPtSl1uMP2cLbDiqA01OWveChktOXwU6hRQ+7MmO+dNRS/iXrRmYrGv/p1W811QgLBLS9fefEdF25n+0dP71L7Ov7riOawlDmd0C11FraE/R8HX6gs6lbXta1kisdxGyKojYSiCtobUaJxRoatMfUP0a9rwTAyl8tf56LgB+igjMky879VAbL7eQ/AmfHYPrSGJ/YlWP6Jj23Dnos5nOVlWL/rVTs9Y/NakLpPwMs75KTC0Pd74hdf2e3folDdAi2kLrQgO2SI6so7rOYZ+mFkCM751QdDVy4DzjmDvSgSIVf9SV7RQf7e7unE7pSZ/ILupZqz9KhR1MOwVO+ePa5qJMNSdC204PIsRWkIO5KP0QLl507NI9Ri84+aODoHD7gDIWNhU08J2P8/E6r0wcC8uWaxh+HaOjI9BkHjqRYsrgfn54BAuO9kw1cDvyi3c8n7VFlNtvQP15lANwim3gr9upV+r95KEPJCgZMYWJBDPIVtp4GdYxCfXxWj5oMXbA5pf0tNixwNJjAsY7I6RN2htHbuySH36JybOZk+gCj6mQkxpCT/tKaUn14hBJWLq7Q+Q==" >> ~/.ssh/known_hosts
+  echo "|1|JZkdAPJmpX6SzGeqhmQLfMWLGQA=|4vTELroOlbFxbCr0WX+PK9EcpD0= ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIJknufU+I6A5Nm58lmse4/o11Ai2UzYbYe7782J1+kRk" >> ~/.ssh/known_hosts
+
+  # Setup ssh keys.
+  eval `ssh-agent`
+  echo "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDJPR1vrZgeGTXmgJw2PsJfMjf22LcDnVVwt3l0rwTZ+8Q2J0bHaYxMRKBco1sON6LGcZepw0Hy76RQ87v057pTz18SXvnfE7U/B6v9qBk0ILJz+4BOX9sEhxu2XmScp/wMxkG9IoyruMlsxXzd1sz09o+rzzx24U2Rp27PRm08vG0oipve6BWLbYEqYrE4/nCufqOJmGd56fju7OTU0lTpEkGDEDWGMxutaX2CbTbDju7qy07Ld8BjSc9aHfvuQaslUbj3ex3EF8EXahURzGpHQn/UFFzVGMokFumiJCAagHQb7cj6jOkKseZLaysbA/mTBQsOzjWiRmkN23bQf1wF ben+ghc-ci@smart-cactus.org" > ~/.ssh/perf_rsa.pub
+  touch ~/.ssh/perf_rsa
+  chmod 0600 ~/.ssh/perf_rsa
+  echo "$PERF_NOTE_KEY" >> ~/.ssh/perf_rsa
+  ssh-add ~/.ssh/perf_rsa
+}
+
+# Reset the git notes and append the metrics file to the notes, then push and return the result.
+# This is favoured over a git notes merge as it avoids potential data loss/duplication from the merge strategy.
+function reset_append_note_push {
+  pull || true
+  run git notes --ref=$REF append -F $METRICS_FILE HEAD
+  run git push $NOTES_ORIGIN_PUSH refs/notes/$REF
+}
+
+function push() {
+  # Check that private key is available (Set on all GitLab protected branches).
+  if [ -z ${PERF_NOTE_KEY+"$PERF_NOTE_KEY"} ]
+  then
+    echo "Not pushing performance git notes: PERF_NOTE_KEY is not set."
+    exit 0
+  fi
+
+  # TEST_ENV must be set.
+  if [ -z ${TEST_ENV+"$TEST_ENV"} ]
+  then
+    fail "Not pushing performance git notes: TEST_ENV must be set."
+  fi
+
+  # Assert that the METRICS_FILE exists and can be read.
+  if [ -z ${METRICS_FILE+"$METRICS_FILE"} ]
+  then
+    fail "\$METRICS_FILE not set."
+  fi
+  if ! [ -r $METRICS_FILE ]
+  then
+    fail "Metrics file not found: $METRICS_FILE"
+  fi
+
+  setup_ssh
+
+  # Push the metrics file as a git note. This may fail if another task pushes a note first. In that case
+  # the latest note is fetched and appended.
+  MAX_RETRY=20
+  until reset_append_note_push || [ $MAX_RETRY -le 0 ]
+  do
+    ((MAX_RETRY--))
+    echo ""
+    echo "Failed to push git notes. Fetching, appending, and retrying... $MAX_RETRY retries left."
+  done
+}
+
+case $1 in
+  push) push ;;
+  pull) pull ;;
+  *) fail "Invalid mode $1" ;;
+esac

.gitlab/win32-init.sh

-#!/bin/bash
-
-set -e
-
-toolchain=`pwd`/toolchain
-PATH="$toolchain/bin:/mingw64/bin:$PATH"
-
-if [ -d "`pwd`/cabal-cache" ]; then
-    cp -Rf cabal-cache $APPDATA/cabal
-fi
-
-if [ ! -e $toolchain/bin/ghc ]; then
-    case $MSYSTEM in
-      MINGW32)
-        triple="i386-unknown-mingw32"
-        ;;
-      MINGW64)
-        triple="x86_64-unknown-mingw32"
-        ;;
-      *)
-        echo "win32-init: Unknown MSYSTEM $MSYSTEM"
-        exit 1
-        ;;
-    esac
-    curl https://downloads.haskell.org/~ghc/$GHC_VERSION/ghc-$GHC_VERSION-$triple.tar.xz | tar -xJ
-    mv ghc-$GHC_VERSION toolchain
-fi
-
-if [ ! -e $toolchain/bin/cabal ]; then
-    url="https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-unknown-mingw32.zip"
-    curl $url > /tmp/cabal.zip
-    unzip /tmp/cabal.zip
-    mv cabal.exe $toolchain/bin
-fi
-
-if [ ! -e $toolchain/bin/happy ]; then
-    cabal update
-    cabal install happy
-    cp $APPDATA/cabal/bin/happy $toolchain/bin
-fi
-
-if [ ! -e $toolchain/bin/alex ]; then
-    cabal update
-    cabal install alex
-    cp $APPDATA/cabal/bin/alex $toolchain/bin
-fi
-
-# Install new process to mitigate #17480.
-cabal install libraries/process

aclocal.m4

@@ -3,6 +3,15 @@
 # To be a good autoconf citizen, names of local macros have prefixed with FP_ to
 # ensure we don't clash with any pre-supplied autoconf ones.
 
+# FPTOOLS_WRITE_FILE
+# ------------------
+# Write $2 to the file named $1.
+AC_DEFUN([FPTOOLS_WRITE_FILE],
+[
+cat >$1 <<ACEOF
+$2
+ACEOF
+])
 
 AC_DEFUN([GHC_SELECT_FILE_EXTENSIONS],
 [
@@ -507,6 +516,10 @@ AC_DEFUN([FP_SETTINGS],
         SettingsHaskellCPPCommand="${mingw_bin_prefix}gcc.exe"
         SettingsHaskellCPPFlags="$HaskellCPPArgs"
         SettingsLdCommand="${mingw_bin_prefix}ld.exe"
+        # Overrides FIND_MERGE_OBJECTS in order to avoid hard-coding linker
+        # path on Windows (#18550).
+        SettingsMergeObjectsCommand="${SettingsLdCommand}"
+        SettingsMergeObjectsFlags="-r --oformat=pe-bigobj-x86-64"
         SettingsArCommand="${mingw_bin_prefix}ar.exe"
         SettingsRanlibCommand="${mingw_bin_prefix}ranlib.exe"
         SettingsDllWrapCommand="${mingw_bin_prefix}dllwrap.exe"
@@ -520,6 +533,8 @@ AC_DEFUN([FP_SETTINGS],
         SettingsHaskellCPPCommand="$(basename $HaskellCPPCmd)"
         SettingsHaskellCPPFlags="$HaskellCPPArgs"
         SettingsLdCommand="$(basename $LdCmd)"
+        SettingsMergeObjectsCommand="$(basename $MergeObjsCmd)"
+        SettingsMergeObjectsFlags="$MergeObjsArgs"
         SettingsArCommand="$(basename $ArCmd)"
         SettingsDllWrapCommand="$(basename $DllWrapCmd)"
         SettingsWindresCommand="$(basename $WindresCmd)"
@@ -529,6 +544,8 @@ AC_DEFUN([FP_SETTINGS],
         SettingsHaskellCPPCommand="$HaskellCPPCmd"
         SettingsHaskellCPPFlags="$HaskellCPPArgs"
         SettingsLdCommand="$LdCmd"
+        SettingsMergeObjectsCommand="$MergeObjsCmd"
+        SettingsMergeObjectsFlags="$MergeObjsArgs"
         SettingsArCommand="$ArCmd"
         SettingsRanlibCommand="$RanlibCmd"
         if test -z "$DllWrapCmd"
@@ -569,6 +586,18 @@ AC_DEFUN([FP_SETTINGS],
     else
       SettingsOptCommand="$OptCmd"
     fi
+    if test -z "$OtoolCmd"
+    then
+      SettingsOtoolCommand="otool"
+    else
+      SettingsOtoolCommand="$OtoolCmd"
+    fi
+    if test -z "$InstallNameToolCmd"
+    then
+      SettingsInstallNameToolCommand="install_name_tool"
+    else
+      SettingsInstallNameToolCommand="$InstallNameToolCmd"
+    fi
     SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2"
     SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2"
     SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2"
@@ -583,8 +612,12 @@ AC_DEFUN([FP_SETTINGS],
     AC_SUBST(SettingsCCompilerSupportsNoPie)
     AC_SUBST(SettingsLdCommand)
     AC_SUBST(SettingsLdFlags)
+    AC_SUBST(SettingsMergeObjectsCommand)
+    AC_SUBST(SettingsMergeObjectsFlags)
     AC_SUBST(SettingsArCommand)
     AC_SUBST(SettingsRanlibCommand)
+    AC_SUBST(SettingsOtoolCommand)
+    AC_SUBST(SettingsInstallNameToolCommand)
     AC_SUBST(SettingsDllWrapCommand)
     AC_SUBST(SettingsWindresCommand)
     AC_SUBST(SettingsLibtoolCommand)
@@ -1318,19 +1351,25 @@ AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],[
 # (unsubstituted) output variable GccVersion.
 AC_DEFUN([FP_GCC_VERSION], [
   AC_REQUIRE([AC_PROG_CC])
-  if test -z "$CC"
-  then
-    AC_MSG_ERROR([gcc is required])
+  if test -z "$CC"; then
+    AC_MSG_ERROR([C compiler is required])
+  fi
+
+  if $CC --version | grep --quiet gcc; then
+    AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version],
+    [
+        # Be sure only to look at the first occurrence of the "version " string;
+        # Some Apple compilers emit multiple messages containing this string.
+        AC_MSG_CHECKING([version of gcc])
+        fp_cv_gcc_version="`$CC -v 2>&1 | sed -n -e '1,/version /s/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/p'`"
+        AC_MSG_RESULT([$fp_cv_gcc_version])
+        FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6],
+                            [AC_MSG_ERROR([Need at least gcc version 4.6 (4.7+ recommended)])])
+    ])
+    AC_SUBST([GccVersion], [$fp_cv_gcc_version])
+  else
+    AC_MSG_NOTICE([\$CC is not gcc; assuming it's a reasonably new C compiler])
   fi
-  AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version],
-  [
-      # Be sure only to look at the first occurrence of the "version " string;
-      # Some Apple compilers emit multiple messages containing this string.
-      fp_cv_gcc_version="`$CC -v 2>&1 | sed -n -e '1,/version /s/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/p'`"
-      FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6],
-                          [AC_MSG_ERROR([Need at least gcc version 4.6 (4.7+ recommended)])])
-  ])
-  GccVersion="$fp_cv_gcc_version"
 ])# FP_GCC_VERSION
 
 dnl Check to see if the C compiler is clang or llvm-gcc
@@ -1555,13 +1594,12 @@ AC_SUBST([GhcPkgCmd])
 AC_DEFUN([FP_GCC_EXTRA_FLAGS],
 [AC_REQUIRE([FP_GCC_VERSION])
 AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts],
-[fp_cv_gcc_extra_opts=
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4],
-  [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"],
-  [])
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.0],
-  [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-builtin"],
-  [])
+[
+ if test "$Unregisterised" = "YES"; then
+   # These used to be conditioned on gcc version but we no longer support
+   # GCC versions which lack support for these flags
+   fp_cv_gcc_extra_opts="-fwrapv -fno-builtin"
+ fi
 ])
 AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts)
 ])
@@ -2108,39 +2146,39 @@ fi
 AC_SUBST($1)
 ])
 
-# LIBRARY_VERSION(lib, [dir])
+# LIBRARY_VERSION(lib, [cabal_file])
 # --------------------------------
 # Gets the version number of a library.
 # If $1 is ghc-prim, then we define LIBRARY_ghc_prim_VERSION as 1.2.3
 # $2 points to the directory under libraries/
 AC_DEFUN([LIBRARY_VERSION],[
-dir=m4_default([$2],[$1])
-LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/${dir}/$1.cabal | sed "s/.* //"`
+cabal_file=m4_default([$2],[$1/$1.cabal])
+LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/${cabal_file} | sed "s/.* //"`
 AC_SUBST(LIBRARY_[]translit([$1], [-], [_])[]_VERSION)
 ])
 
 # XCODE_VERSION()
 # --------------------------------
-# Gets the version number of XCode, if on a Mac
+# Gets the version number of Xcode, if on a Mac
 AC_DEFUN([XCODE_VERSION],[
     if test "$TargetVendor_CPP" = "apple"
     then
-        AC_MSG_CHECKING(XCode version)
-        XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"`
-        # Old XCode versions don't actually give the XCode version
-        if test "$XCodeVersion" = ""
+        AC_MSG_CHECKING(Xcode version)
+        XcodeVersion=`(xcode-select -p >& /dev/null && xcodebuild -version) | grep Xcode | sed "s/Xcode //"`
+        # Old Xcode versions don't actually give the Xcode version
+        if test "$XcodeVersion" = ""
         then
             AC_MSG_RESULT(not found (too old?))
-            XCodeVersion1=0
-            XCodeVersion2=0
+            XcodeVersion1=0
+            XcodeVersion2=0
         else
-            AC_MSG_RESULT($XCodeVersion)
-            XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'`
+            AC_MSG_RESULT($XcodeVersion)
+            XcodeVersion1=`echo "$XcodeVersion" | sed 's/\..*//'`
             changequote(, )dnl
-            XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'`
+            XcodeVersion2=`echo "$XcodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'`
             changequote([, ])dnl
-            AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1)
-            AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2)
+            AC_MSG_NOTICE(Xcode version component 1: $XcodeVersion1)
+            AC_MSG_NOTICE(Xcode version component 2: $XcodeVersion2)
         fi
     fi
 ])
@@ -2450,7 +2488,6 @@ AC_DEFUN([FIND_LD],[
         # Make sure the user didn't specify LD manually.
         if test "z$LD" != "z"; then
             AC_CHECK_TARGET_TOOL([LD], [ld])
-            LD_NO_GOLD=$LD
             return
         fi
 
@@ -2463,7 +2500,6 @@ AC_DEFUN([FIND_LD],[
             if test "x$TmpLd" = "x"; then continue; fi
 
             out=`$TmpLd --version`
-            LD_NO_GOLD=$TmpLd
             case $out in
               "GNU ld"*)
                    FP_CC_LINKER_FLAG_TRY(bfd, $2) ;;
@@ -2471,8 +2507,6 @@ AC_DEFUN([FIND_LD],[
                    FP_CC_LINKER_FLAG_TRY(gold, $2)
                    if test "$cross_compiling" = "yes"; then
                        AC_MSG_NOTICE([Using ld.gold and assuming that it is not affected by binutils issue 22266]);
-                   else
-                       LD_NO_GOLD=ld;
                    fi
                    ;;
               "LLD"*)
@@ -2493,19 +2527,147 @@ AC_DEFUN([FIND_LD],[
 
         # Fallback
         AC_CHECK_TARGET_TOOL([LD], [ld])
-        # This isn't entirely safe since $LD may have been discovered to be
-        # ld.gold, but what else can we do?
-        if test "x$LD_NO_GOLD" = "x"; then LD_NO_GOLD=$LD; fi
     }
 
     if test "x$enable_ld_override" = "xyes"; then
         find_ld
     else
         AC_CHECK_TARGET_TOOL([LD], [ld])
-        if test "x$LD_NO_GOLD" = "x"; then LD_NO_GOLD=$LD; fi
     fi
 
     CHECK_LD_COPY_BUG([$1])
 ])
 
+
+# CHECK_FOR_GOLD_T22266
+# ----------------------
+#
+# Test for binutils #22266. This bug manifested as GHC bug #14328 (see also:
+# #14675, #14291).
+# Uses test from
+# https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=033bfb739b525703bfe23f151d09e9beee3a2afe
+#
+# $1 = linker to test
+# Sets $result to 0 if not affected, 1 otherwise
+AC_DEFUN([CHECK_FOR_GOLD_T22266],[
+    AC_MSG_CHECKING([for ld.gold object merging bug (binutils 22266)])
+    if ! $1 --version | grep -q "GNU gold"; then
+        # Not gold
+        result=0
+    elif test "$cross_compiling" = "yes"; then
+        AC_MSG_RESULT([cross-compiling, assuming LD can merge objects correctly.])
+        result=0
+    else
+        FPTOOLS_WRITE_FILE([conftest.a.c], [
+          __attribute__((section(".data.a")))
+          static int int_from_a_1 = 0x11223344;
+
+          __attribute__((section(".data.rel.ro.a")))
+          int *p_int_from_a_2 = &int_from_a_1;
+
+          const char *hello (void);
+
+          const char *
+          hello (void)
+          {
+            return "XXXHello, world!" + 3;
+          }
+        ])
+
+        FPTOOLS_WRITE_FILE([conftest.main.c], [
+          #include <stdlib.h>
+          #include <string.h>
+
+          extern int *p_int_from_a_2;
+          extern const char *hello (void);
+
+          int main (void) {
+            if (*p_int_from_a_2 != 0x11223344)
+              abort ();
+            if (strcmp(hello(), "Hello, world!") != 0)
+              abort ();
+            return 0;
+          }
+        ])
+
+        FPTOOLS_WRITE_FILE([conftest.t], [
+          SECTIONS
+          {
+              .text : {
+                  *(.text*)
+              }
+              .rodata :
+              {
+                  *(.rodata .rodata.* .gnu.linkonce.r.*)
+              }
+              .data.rel.ro : {
+                  *(.data.rel.ro*)
+              }
+              .data : {
+                  *(.data*)
+              }
+              .bss : {
+                  *(.bss*)
+              }
+          }
+        ])
+
+        $CC -c -o conftest.a.o conftest.a.c || AC_MSG_ERROR([Failed to compile test])
+        $MergeObjsCmd $MergeObjsArgs -T conftest.t conftest.a.o -o conftest.ar.o || AC_MSG_ERROR([Failed to merge test object])
+
+        $CC -c -o conftest.main.o conftest.main.c || AC_MSG_ERROR([Failed to compile test driver])
+        $CC conftest.ar.o conftest.main.o -o conftest || AC_MSG_ERROR([Failed to link test driver])
+
+        if ./conftest; then
+            AC_MSG_RESULT([not affected])
+            result=0
+        else
+            AC_MSG_RESULT([affected])
+            result=1
+        fi
+        rm -f conftest.a.o conftest.a.c  conttest.ar.o conftest.main.c conftest.main.o conftest
+    fi
+])
+
+# FIND_MERGE_OBJECTS
+# ------------------
+# Find which linker to use to merge object files.
+#
+# See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
+AC_DEFUN([FIND_MERGE_OBJECTS],[
+    AC_REQUIRE([FIND_LD])
+
+    if test -z "$MergeObjsCmd"; then
+        MergeObjsCmd="$LD"
+    fi
+    if test -z "$MergeObjsArgs"; then
+        MergeObjsArgs="-r"
+    fi
+
+    CHECK_FOR_GOLD_T22266($MergeObjsCmd)
+    if test "$result" = "1"; then
+        AC_MSG_NOTICE([$MergeObjsCmd is broken due to binutils 22266, looking for another linker...])
+        MergeObjsCmd=""
+        AC_CHECK_TARGET_TOOL([MergeObjsCmd], [ld])
+        CHECK_FOR_GOLD_T22266($MergeObjsCmd)
+        if test "$result" = "1"; then
+            AC_MSG_ERROR([Linker is affected by binutils 22266 but couldn't find another unaffected linker. Please set the MergeObjsCmd variable to a functional linker.])
+        fi
+    fi
+
+    AC_SUBST([MergeObjsCmd])
+    AC_SUBST([MergeObjsArgs])
+])
+
+# FIND_PYTHON
+# -----------
+# Find the version of `python` to use (for the testsuite driver)
+#
+AC_DEFUN([FIND_PYTHON],[
+    dnl Prefer the mingw64 distribution on Windows due to #17483.
+    AC_PATH_PROG([PYTHON], [python3], [], [/mingw64/bin $PATH])
+    PythonCmd="$PYTHON"
+    AC_SUBST([PythonCmd])
+])
+
 # LocalWords:  fi

compiler/GHC/Hs/Decls.hs

@@ -81,7 +81,7 @@ module GHC.Hs.Decls (
   RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
   -- ** Injective type families
   FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
-  resultVariableName,
+  resultVariableName, familyDeclLName, familyDeclName,
 
   -- * Grouping
   HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls
@@ -661,11 +661,14 @@ tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec)))
 tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec))
   = noExtCon nec
 
-tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
-tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
-tyClDeclLName decl = tcdLName decl
+tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))
+tyClDeclLName (FamDecl { tcdFam = fd })     = familyDeclLName fd
+tyClDeclLName (SynDecl { tcdLName = ln })   = ln
+tyClDeclLName (DataDecl { tcdLName = ln })  = ln
+tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
+tyClDeclLName (XTyClDecl nec) = noExtCon nec
 
-tcdName :: TyClDecl pass -> IdP pass
+tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)
 tcdName = unLoc . tyClDeclLName
 
 tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
@@ -1091,6 +1094,16 @@ data FamilyInfo pass
      -- said "type family Foo x where .."
   | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
 
+
+------------- Functions over FamilyDecls -----------
+
+familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p))
+familyDeclLName (FamilyDecl { fdLName = n }) = n
+familyDeclLName (XFamilyDecl nec) = noExtCon nec
+
+familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)
+familyDeclName = unLoc . familyDeclLName
+
 famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
 famResultKindSignature (NoSig _) = Nothing
 famResultKindSignature (KindSig _ ki) = Just ki
@@ -1106,6 +1119,8 @@ resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
 resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig
 resultVariableName _                = Nothing
 
+------------- Pretty printing FamilyDecls -----------
+
 instance OutputableBndrId p
        => Outputable (FamilyDecl (GhcPass p)) where
   ppr = pprFamilyDecl TopLevel

compiler/GHC/Hs/Expr.hs

@@ -37,6 +37,7 @@ import CoreSyn
 import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
 import Name
 import NameSet
+import RdrName  ( GlobalRdrEnv )
 import BasicTypes
 import ConLike
 import SrcLoc
@@ -188,6 +189,104 @@ is Less Cool because
     typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
 -}
 
+-- | An unbound variable; used for treating
+-- out-of-scope variables as expression holes
+--
+-- Either "x", "y"     Plain OutOfScope
+-- or     "_", "_x"    A TrueExprHole
+--
+-- Both forms indicate an out-of-scope variable,  but the latter
+-- indicates that the user /expects/ it to be out of scope, and
+-- just wants GHC to report its type
+data UnboundVar
+  = OutOfScope OccName GlobalRdrEnv  -- ^ An (unqualified) out-of-scope
+                                     -- variable, together with the GlobalRdrEnv
+                                     -- with respect to which it is unbound
+
+                                     -- See Note [OutOfScope and GlobalRdrEnv]
+
+  | TrueExprHole OccName             -- ^ A "true" expression hole (_ or _x)
+
+  deriving Data
+
+instance Outputable UnboundVar where
+    ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ)
+    ppr (TrueExprHole occ) = text "ExprHole"   <> parens (ppr occ)
+
+unboundVarOcc :: UnboundVar -> OccName
+unboundVarOcc (OutOfScope occ _) = occ
+unboundVarOcc (TrueExprHole occ) = occ
+
+{-
+Note [OutOfScope and GlobalRdrEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To understand why we bundle a GlobalRdrEnv with an out-of-scope variable,
+consider the following module:
+
+    module A where
+
+    foo :: ()
+    foo = bar
+
+    bat :: [Double]
+    bat = [1.2, 3.4]
+
+    $(return [])
+
+    bar = ()
+    bad = False
+
+When A is compiled, the renamer determines that `bar` is not in scope in the
+declaration of `foo` (since `bar` is declared in the following inter-splice
+group).  Once it has finished typechecking the entire module, the typechecker
+then generates the associated error message, which specifies both the type of
+`bar` and a list of possible in-scope alternatives:
+
+    A.hs:6:7: error:
+        • Variable not in scope: bar :: ()
+        • ‘bar’ (line 13) is not in scope before the splice on line 11
+          Perhaps you meant ‘bat’ (line 9)
+
+When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the
+typechecker must provide a GlobalRdrEnv.  If it provided the current one, which
+contains top-level declarations for the entire module, the error message would
+incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives
+for `bar` (see #11680).  Instead, the typechecker must use the same
+GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope.
+
+To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope
+`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to
+look it up in some global store?  Unfortunately, no.  The problem is that
+location information is not always sufficient for this task.  This is most
+apparent when dealing with the TH function addTopDecls, which adds its
+declarations to the FOLLOWING inter-splice group.  Consider these declarations:
+
+    ex9 = cat               -- cat is NOT in scope here
+
+    $(do -------------------------------------------------------------
+        ds <- [d| f = cab   -- cat and cap are both in scope here
+                  cat = ()
+                |]
+        addTopDecls ds
+        [d| g = cab         -- only cap is in scope here
+            cap = True
+          |])
+
+    ex10 = cat              -- cat is NOT in scope here
+
+    $(return []) -----------------------------------------------------
+
+    ex11 = cat              -- cat is in scope
+
+Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs
+the GlobalRdrEnvs which were used when they were renamed.  These GlobalRdrEnvs
+are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the
+locations of the two `cab`s are the same (they are both created in the same
+splice).  Thus, we must include some additional information with each `cab` to
+allow the typechecker to obtain the correct GlobalRdrEnv.  Clearly, the simplest
+information to use is the GlobalRdrEnv itself.
+-}
+
 -- | A Haskell expression.
 data HsExpr p
   = HsVar     (XVar p)
@@ -196,7 +295,7 @@ data HsExpr p
                              -- See Note [Located RdrNames]
 
   | HsUnboundVar (XUnboundVar p)
-                 OccName     -- ^ Unbound variable; also used for "holes"
+                 UnboundVar  -- ^ Unbound variable; also used for "holes"
                              --   (_ or _x).
                              -- Turned from HsVar to HsUnboundVar by the
                              --   renamer, when it finds an out-of-scope
@@ -849,7 +948,7 @@ ppr_lexpr e = ppr_expr (unLoc e)
 ppr_expr :: forall p. (OutputableBndrId p)
          => HsExpr (GhcPass p) -> SDoc
 ppr_expr (HsVar _ (L _ v))  = pprPrefixOcc v
-ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc uv
+ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv)
 ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c
 ppr_expr (HsIPVar _ v)      = ppr v
 ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l
@@ -1042,7 +1141,7 @@ ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
 ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)
 ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))
 ppr_infix_expr (HsRecFld _ f)       = Just (pprInfixOcc f)
-ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
+ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h))
 ppr_infix_expr (HsWrap _ _ e)       = ppr_infix_expr e
 ppr_infix_expr _                    = Nothing
 
@@ -2181,22 +2280,30 @@ pprStmt (ApplicativeStmt _ args mb_join)
           else text "join" <+> parens ap_expr
 
    pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
-   pp_arg (_, ApplicativeArgOne _ pat expr isBody _)
-     | isBody =  -- See Note [Applicative BodyStmt]
-     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+   pp_arg (_, applicativeArg) = ppr applicativeArg
+
+pprStmt (XStmtLR x) = ppr x
+
+
+instance (OutputableBndrId idL)
+      => Outputable (ApplicativeArg (GhcPass idL)) where
+  ppr = pprArg
+
+pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
+pprArg (ApplicativeArgOne _ pat expr isBody _)
+  | isBody =  -- See Note [Applicative BodyStmt]
+    ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
-     | otherwise =
-     ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+  | otherwise =
+    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
-   pp_arg (_, ApplicativeArgMany _ stmts return pat) =
+pprArg (ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
      text "<-" <+>
      ppr (HsDo (panic "pprStmt") DoExpr (noLoc
                (stmts ++
                    [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)])))
-   pp_arg (_, XApplicativeArg x) = ppr x
-
-pprStmt (XStmtLR x) = ppr x
+pprArg (XApplicativeArg x) = ppr x
 
 pprTransformStmt :: (OutputableBndrId p)
                  => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)

compiler/GHC/Hs/Types.hs

@@ -56,8 +56,7 @@ module GHC.Hs.Types (
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
         splitLHsPatSynTy,
-        splitLHsForAllTy, splitLHsForAllTyInvis,
-        splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis,
+        splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis,
         splitHsFunType, hsTyGetAppHead_maybe,
         mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
         ignoreParens, hsSigType, hsSigWcType,
@@ -1248,21 +1247,9 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
     (provs, ty4) = splitLHsQualTy ty3
 
 -- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
--- into its constituent parts.
---
--- Note that this function looks through parentheses, so it will work on types
--- such as @(forall a. <...>)@. The downside to this is that it is not
--- generally possible to take the returned types and reconstruct the original
--- type (parentheses and all) from them.
-splitLHsSigmaTy :: LHsType pass
-                -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
-splitLHsSigmaTy ty
-  | (tvs, ty1)  <- splitLHsForAllTy ty
-  , (ctxt, ty2) <- splitLHsQualTy ty1
-  = (tvs, ctxt, ty2)
-
--- | Like 'splitLHsSigmaTy', but only splits type variable binders that were
--- quantified invisibly (e.g., @forall a.@, with a dot).
+-- into its constituent parts. Note that only /invisible/ @forall@s
+-- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s
+-- (i.e., @forall a ->@, with an arrow) are left untouched.
 --
 -- This function is used to split apart certain types, such as instance
 -- declaration types, which disallow visible @forall@s. For instance, if GHC
@@ -1280,20 +1267,10 @@ splitLHsSigmaTyInvis ty
   , (ctxt, ty2) <- splitLHsQualTy ty1
   = (tvs, ctxt, ty2)
 
--- | Decompose a type of the form @forall <tvs>. body@) into its constituent
--- parts.
---
--- Note that this function looks through parentheses, so it will work on types
--- such as @(forall a. <...>)@. The downside to this is that it is not
--- generally possible to take the returned types and reconstruct the original
--- type (parentheses and all) from them.
-splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
-splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
-splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
-splitLHsForAllTy body              = ([], body)
-
--- | Like 'splitLHsForAllTy', but only splits type variable binders that
--- were quantified invisibly (e.g., @forall a.@, with a dot).
+-- | Decompose a type of the form @forall <tvs>. body@ into its constituent
+-- parts. Note that only /invisible/ @forall@s
+-- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s
+-- (i.e., @forall a ->@, with an arrow) are left untouched.
 --
 -- This function is used to split apart certain types, such as instance
 -- declaration types, which disallow visible @forall@s. For instance, if GHC

compiler/GHC/Hs/Utils.hs

@@ -48,7 +48,7 @@ module GHC.Hs.Utils(
   mkChunkified, chunkify,
 
   -- * Bindings
-  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
+  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
   mkPatSynBind,
   isInfixFunBind,
 
@@ -800,14 +800,15 @@ l
 ************************************************************************
 -}
 
-mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
           -> HsBind GhcPs
 -- ^ Not infix, with place holders for coercion and free vars
-mkFunBind fn ms = FunBind { fun_id = fn
-                          , fun_matches = mkMatchGroup Generated ms
-                          , fun_co_fn = idHsWrapper
-                          , fun_ext = noExtField
-                          , fun_tick = [] }
+mkFunBind origin fn ms
+  = FunBind { fun_id = fn
+            , fun_matches = mkMatchGroup origin ms
+            , fun_co_fn = idHsWrapper
+            , fun_ext = noExtField
+            , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
              -> HsBind GhcRn
@@ -820,7 +821,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_tick = [] }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
-mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
 
 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
 mkVarBind var rhs = cL (getLoc rhs) $
@@ -846,10 +847,12 @@ isInfixFunBind _ = False
 
 
 ------------
-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
+-- | Convenience function using 'mkFunBind'.
+-- This is for generated bindings only, do not use for user-written code.
+mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
-mk_easy_FunBind loc fun pats expr
-  = cL loc $ mkFunBind (cL loc fun)
+mkSimpleGeneratedFunBind loc fun pats expr
+  = cL loc $ mkFunBind Generated (cL loc fun)
               [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 

compiler/GHC/HsToCore/PmCheck/Oracle.hs

@@ -1236,10 +1236,11 @@ checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> DsM Bool
 checkAllNonVoid rec_ts amb_cs strict_arg_tys = do
   let definitely_inhabited = definitelyInhabitedType (delta_ty_st amb_cs)
   tys_to_check <- filterOutM definitely_inhabited strict_arg_tys
+  -- See Note [Fuel for the inhabitation test]
   let rec_max_bound | tys_to_check `lengthExceeds` 1
                     = 1
                     | otherwise
-                    = defaultRecTcMaxBound
+                    = 3
       rec_ts' = setRecTcMaxBound rec_max_bound rec_ts
   allM (nonVoid rec_ts' amb_cs) tys_to_check
 
@@ -1259,6 +1260,7 @@ nonVoid rec_ts amb_cs strict_arg_ty = do
   mb_cands <- inhabitationCandidates amb_cs strict_arg_ty
   case mb_cands of
     Right (tc, _, cands)
+      -- See Note [Fuel for the inhabitation test]
       |  Just rec_ts' <- checkRecTc rec_ts tc
       -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands
            -- A strict argument type is inhabitable by a terminating value if
@@ -1307,7 +1309,7 @@ definitelyInhabitedType ty_st ty = do
       null (dataConImplBangs con) -- (2)
 
 {- Note [Strict argument type constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In the ConVar case of clause processing, each conlike K traditionally
 generates two different forms of constraints:
 
@@ -1337,6 +1339,7 @@ say, `K2 undefined` or `K2 (let x = x in x)`.)
 Since neither the term nor type constraints mentioned above take strict
 argument types into account, we make use of the `nonVoid` function to
 determine whether a strict type is inhabitable by a terminating value or not.
+We call this the "inhabitation test".
 
 `nonVoid ty` returns True when either:
 1. `ty` has at least one InhabitationCandidate for which both its term and type
@@ -1362,15 +1365,20 @@ determine whether a strict type is inhabitable by a terminating value or not.
   `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid
   constructor contains Void as a strict argument type, and since `nonVoid Void`
   returns False, that InhabitationCandidate is discarded, leaving no others.
+* Whether or not a type is inhabited is undecidable in general.
+  See Note [Fuel for the inhabitation test].
+* For some types, inhabitation is evident immediately and we don't need to
+  perform expensive tests. See Note [Types that are definitely inhabitable].
 
-* Performance considerations
+Note [Fuel for the inhabitation test]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whether or not a type is inhabited is undecidable in general. As a result, we
+can run into infinite loops in `nonVoid`. Therefore, we adopt a fuel-based
+approach to prevent that.
 
-We must be careful when recursively calling `nonVoid` on the strict argument
-types of an InhabitationCandidate, because doing so naïvely can cause GHC to
-fall into an infinite loop. Consider the following example:
+Consider the following example:
 
   data Abyss = MkAbyss !Abyss
-
   stareIntoTheAbyss :: Abyss -> a
   stareIntoTheAbyss x = case x of {}
 
@@ -1391,7 +1399,6 @@ stareIntoTheAbyss above. Then again, the same problem occurs with recursive
 newtypes, like in the following code:
 
   newtype Chasm = MkChasm Chasm
-
   gazeIntoTheChasm :: Chasm -> a
   gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive
 
@@ -1415,9 +1422,26 @@ maximum recursion depth to 1 to mitigate the problem. If the branching factor
 is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay
 to stick with a larger maximum recursion depth.
 
+In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was
+too large and had detrimental effect on performance of the coverage checker.
+Given that we only commit to a best effort anyway, we decided to substantially
+decrement the recursion depth to 3, at the cost of precision in some edge cases
+like
+
+  data Nat = Z | S Nat
+  data Down :: Nat -> Type where
+    Down :: !(Down n) -> Down (S n)
+  f :: Down (S (S (S (S (S Z))))) -> ()
+  f x = case x of {}
+
+Since the coverage won't bother to instantiate Down 4 levels deep to see that it
+is in fact uninhabited, it will emit a inexhaustivity warning for the case.
+
+Note [Types that are definitely inhabitable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Another microoptimization applies to data types like this one:
 
-  data S a = ![a] !T
+  data S a = S ![a] !T
 
 Even though there is a strict field of type [a], it's quite silly to call
 nonVoid on it, since it's "obvious" that it is inhabitable. To make this

compiler/GHC/StgToCmm/Closure.hs

@@ -362,20 +362,19 @@ type DynTag = Int       -- The tag on a *pointer*
 --    * big, otherwise.
 --
 -- Small families can have the constructor tag in the tag bits.
--- Big families only use the tag value 1 to represent evaluatedness.
+-- Big families always use the tag values 1..mAX_PTR_TAG to represent
+-- evaluatedness, the last one lumping together all overflowing ones.
 -- We don't have very many tag bits: for example, we have 2 bits on
 -- x86-32 and 3 bits on x86-64.
+--
+-- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
 
 isSmallFamily :: DynFlags -> Int -> Bool
 isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
 
 tagForCon :: DynFlags -> DataCon -> DynTag
-tagForCon dflags con
-  | isSmallFamily dflags fam_size = con_tag
-  | otherwise                     = 1
-  where
-    con_tag  = dataConTag con -- NB: 1-indexed
-    fam_size = tyConFamilySize (dataConTyCon con)
+tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags)
+-- NB: 1-indexed
 
 tagForArity :: DynFlags -> RepArity -> DynTag
 tagForArity dflags arity

compiler/GHC/StgToCmm/Expr.hs

-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -32,10 +32,11 @@ import StgSyn
 
 import MkGraph
 import BlockId
-import Cmm
+import Cmm hiding ( succ )
 import CmmInfo
 import CoreSyn
 import DataCon
+import DynFlags         ( mAX_PTR_TAG )
 import ForeignCall
 import Id
 import PrimOp
@@ -48,8 +49,9 @@ import Util
 import FastString
 import Outputable
 
-import Control.Monad (unless,void)
-import Control.Arrow (first)
+import Control.Monad ( unless, void )
+import Control.Arrow ( first )
+import Data.List     ( partition )
 
 ------------------------------------------------------------------------
 --              cgExpr: the main function
@@ -631,29 +633,152 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
 
         ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts
 
-        ; let fam_sz   = tyConFamilySize tycon
-              bndr_reg = CmmLocal (idToReg dflags bndr)
-
-                    -- Is the constructor tag in the node reg?
-        ; if isSmallFamily dflags fam_sz
-          then do
-                let   -- Yes, bndr_reg has constr. tag in ls bits
-                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
-                   branches' = [(tag+1,branch) | (tag,branch) <- branches]
-                emitSwitch tag_expr branches' mb_deflt 1 fam_sz
-
-           else -- No, get tag from info table
-                let -- Note that ptr _always_ has tag 1
-                    -- when the family size is big enough
-                    untagged_ptr = cmmRegOffB bndr_reg (-1)
-                    tag_expr = getConstrTag dflags (untagged_ptr)
-                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
+        ; let !fam_sz   = tyConFamilySize tycon
+              !bndr_reg = CmmLocal (idToReg dflags bndr)
+              !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
+              !branches' = first succ <$> branches
+              !maxpt = mAX_PTR_TAG dflags
+              (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'
+              !small = isSmallFamily dflags fam_sz
+
+                -- Is the constructor tag in the node reg?
+                -- See Note [Tagging big families]
+        ; if small || null via_info
+           then -- Yes, bndr_reg has constructor tag in ls bits
+               emitSwitch ptag_expr branches' mb_deflt 1
+                 (if small then fam_sz else maxpt)
+
+           else -- No, the get exact tag from info table when mAX_PTR_TAG
+                -- See Note [Double switching for big families]
+              do
+                let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)
+                    !itag_expr = getConstrTag dflags untagged_ptr
+                    !info0 = first pred <$> via_info
+                if null via_ptr then
+                  emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)
+                else do
+                  infos_lbl <- newBlockId
+                  infos_scp <- getTickScope
+
+                  let spillover = (maxpt, (mkBranch infos_lbl, infos_scp))
+
+                  (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of
+                      (Just (stmts, scp)) ->
+                          do lbl <- newBlockId
+                             return ( Just (mkLabel lbl scp <*> stmts, scp)
+                                    , Just (mkBranch lbl, scp))
+                      _ -> return (Nothing, Nothing)
+                  -- Switch on pointer tag
+                  emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt
+                  join_lbl <- newBlockId
+                  emit (mkBranch join_lbl)
+                  -- Switch on info table tag
+                  emitLabel infos_lbl
+                  emitSwitch itag_expr info0 mb_shared_branch
+                    (maxpt - 1) (fam_sz - 1)
+                  emitLabel join_lbl
 
         ; return AssignedDirectly }
 
 cgAlts _ _ _ _ = panic "cgAlts"
         -- UbxTupAlt and PolyAlt have only one alternative
 
+-- Note [Double switching for big families]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- An algebraic data type can have a n >= 0 summands
+-- (or alternatives), which are identified (labeled) by
+-- constructors. In memory they are kept apart by tags
+-- (see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure).
+-- Due to the characteristics of the platform that
+-- contribute to the alignment of memory objects, there
+-- is a natural limit of information about constructors
+-- that can be encoded in the pointer tag. When the mapping
+-- of constructors to the pointer tag range 1..mAX_PTR_TAG
+-- is not injective, then we have a "big data type", also
+-- called a "big (constructor) family" in the literature.
+-- Constructor tags residing in the info table are injective,
+-- but considerably more expensive to obtain, due to additional
+-- memory access(es).
+--
+-- When doing case analysis on a value of a "big data type"
+-- we need two nested switch statements to make up for the lack
+-- of injectivity of pointer tagging, also taking the info
+-- table tag into account. The exact mechanism is described next.
+--
+-- In the general case, switching on big family alternatives
+-- is done by two nested switch statements. According to
+-- Note [Tagging big families], the outer switch
+-- looks at the pointer tag and the inner dereferences the
+-- pointer and switches on the info table tag.
+--
+-- We can handle a simple case first, namely when none
+-- of the case alternatives mention a constructor having
+-- a pointer tag of 1..mAX_PTR_TAG-1. In this case we
+-- simply emit a switch on the info table tag.
+-- Note that the other simple case is when all mentioned
+-- alternatives lie in 1..mAX_PTR_TAG-1, in which case we can
+-- switch on the ptr tag only, just like in the small family case.
+--
+-- There is a single intricacy with a nested switch:
+-- Both should branch to the same default alternative, and as such
+-- avoid duplicate codegen of potentially heavy code. The outer
+-- switch generates the actual code with a prepended fresh label,
+-- while the inner one only generates a jump to that label.
+--
+-- For example, let's assume a 64-bit architecture, so that all
+-- heap objects are 8-byte aligned, and hence the address of a
+-- heap object ends in `000` (three zero bits).
+--
+-- Then consider the following data type
+--
+--   > data Big = T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8
+--   Ptr tag:      1    2    3    4    5    6    7    7    7
+--   As bits:    001  010  011  100  101  110  111  111  111
+--   Info pointer tag (zero based):
+--                 0    1    2    3    4    5    6    7    8
+--
+-- Then     \case T2 -> True; T8 -> True; _ -> False
+-- will result in following code (slightly cleaned-up and
+-- commented -ddump-cmm-from-stg):
+{-
+           R1 = _sqI::P64;  -- scrutinee
+           if (R1 & 7 != 0) goto cqO; else goto cqP;
+       cqP: // global       -- enter
+           call (I64[R1])(R1) returns to cqO, args: 8, res: 8, upd: 8;
+       cqO: // global       -- already WHNF
+           _sqJ::P64 = R1;
+           _cqX::P64 = _sqJ::P64 & 7;  -- extract pointer tag
+           switch [1 .. 7] _cqX::P64 {
+               case 3 : goto cqW;
+               case 7 : goto cqR;
+               default: {goto cqS;}
+           }
+       cqR: // global
+           _cr2 = I32[I64[_sqJ::P64 & (-8)] - 4]; -- tag from info pointer
+           switch [6 .. 8] _cr2::I64 {
+               case 8 : goto cr1;
+               default: {goto cr0;}
+           }
+       cr1: // global
+           R1 = GHC.Types.True_closure+2;
+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+       cr0: // global     -- technically necessary label
+           goto cqS;
+       cqW: // global
+           R1 = GHC.Types.True_closure+2;
+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+       cqS: // global
+           R1 = GHC.Types.False_closure+1;
+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
+-}
+--
+-- For 32-bit systems we only have 2 tag bits in the pointers at our disposal,
+-- so the performance win is dubious, especially in face of the increased code
+-- size due to double switching. But we can take the viewpoint that 32-bit
+-- architectures are not relevant for performance any more, so this can be
+-- considered as moot.
+
 
 -- Note [alg-alt heap check]
 --
@@ -675,6 +800,55 @@ cgAlts _ _ _ _ = panic "cgAlts"
 --   x = R1
 --   goto L1
 
+
+-- Note [Tagging big families]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Both the big and the small constructor families are tagged,
+-- that is, greater unions which overflow the tag space of TAG_BITS
+-- (i.e. 3 on 32 resp. 7 constructors on 64 bit archs).
+--
+-- For example, let's assume a 64-bit architecture, so that all
+-- heap objects are 8-byte aligned, and hence the address of a
+-- heap object ends in `000` (three zero bits).  Then consider
+-- > data Maybe a = Nothing | Just a
+-- > data Day a = Mon | Tue | Wed | Thu | Fri | Sat | Sun
+-- > data Grade = G1 | G2 | G3 | G4 | G5 | G6 | G7 | G8 | G9 | G10
+--
+-- Since `Grade` has more than 7 constructors, it counts as a
+-- "big data type" (also referred to as "big constructor family" in papers).
+-- On the other hand, `Maybe` and `Day` have 7 constructors or fewer, so they
+-- are "small data types".
+--
+-- Then
+--   * A pointer to an unevaluated thunk of type `Maybe Int`, `Day` or `Grade` will end in `000`
+--   * A tagged pointer to a `Nothing`, `Mon` or `G1` will end in `001`
+--   * A tagged pointer to a `Just x`, `Tue` or `G2`  will end in `010`
+--   * A tagged pointer to `Wed` or `G3` will end in `011`
+--       ...
+--   * A tagged pointer to `Sat` or `G6` will end in `110`
+--   * A tagged pointer to `Sun` or `G7` or `G8` or `G9` or `G10` will end in `111`
+--
+-- For big families we employ a mildly clever way of combining pointer and
+-- info-table tagging. We use 1..MAX_PTR_TAG-1 as pointer-resident tags where
+-- the tags in the pointer and the info table are in a one-to-one
+-- relation, whereas tag MAX_PTR_TAG is used as "spill over", signifying
+-- we have to fall back and get the precise constructor tag from the
+-- info-table.
+--
+-- Consequently we now cascade switches, because we have to check
+-- the pointer tag first, and when it is MAX_PTR_TAG, fetch the precise
+-- tag from the info table, and switch on that. The only technically
+-- tricky part is that the default case needs (logical) duplication.
+-- To do this we emit an extra label for it and branch to that from
+-- the second switch. This avoids duplicated codegen. See Trac #14373.
+-- See note [Double switching for big families] for the mechanics
+-- involved.
+--
+-- Also see note [Data constructor dynamic tags]
+-- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging
+--
+
 -------------------
 cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
              -> FCode ( Maybe CmmAGraphScoped

compiler/GHC/StgToCmm/Foreign.hs

@@ -13,6 +13,8 @@ module GHC.StgToCmm.Foreign (
   emitSaveThreadState,
   saveThreadState,
   emitLoadThreadState,
+  emitSaveRegs,
+  emitRestoreRegs,
   loadThreadState,
   emitOpenNursery,
   emitCloseNursery,
@@ -31,6 +33,7 @@ import GHC.StgToCmm.Layout
 import BlockId (newBlockId)
 import Cmm
 import CmmUtils
+import CmmCallConv
 import MkGraph
 import Type
 import RepType
@@ -304,6 +307,32 @@ saveThreadState dflags = do
       else mkNop
     ]
 
+
+
+-- | Save STG registers
+--
+-- STG registers must be saved around a C call, just in case the STG
+-- register is mapped to a caller-saves machine register.  Normally we
+-- don't need to worry about this the code generator has already
+-- loaded any live STG registers into variables for us, but in
+-- hand-written low-level Cmm code where we don't know which registers
+-- are live, we might have to save them all.
+emitSaveRegs :: FCode ()
+emitSaveRegs = do
+   dflags <- getDynFlags
+   let regs = realArgRegsCover dflags
+       save = catAGraphs (map (callerSaveGlobalReg dflags) regs)
+   emit save
+
+-- | Restore STG registers (see 'emitSaveRegs')
+emitRestoreRegs :: FCode ()
+emitRestoreRegs = do
+   dflags <- getDynFlags
+   let regs = realArgRegsCover dflags
+       save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)
+   emit save
+
+
 emitCloseNursery :: FCode ()
 emitCloseNursery = do
   dflags <- getDynFlags

compiler/GHC/StgToCmm/Prim.hs

@@ -82,33 +82,19 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty
   = cgForeignCall fcall ty stg_args res_ty
       -- Note [Foreign call results]
 
--- tagToEnum# is special: we need to pull the constructor
--- out of the table, and perform an appropriate return.
-
-cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
-  = ASSERT(isEnumerationTyCon tycon)
-    do  { dflags <- getDynFlags
-        ; args' <- getNonVoidArgAmodes [arg]
-        ; let amode = case args' of [amode] -> amode
-                                    _ -> panic "TagToEnumOp had void arg"
-        ; emitReturn [tagToClosure dflags tycon amode] }
-   where
-          -- If you're reading this code in the attempt to figure
-          -- out why the compiler panic'ed here, it is probably because
-          -- you used tagToEnum# in a non-monomorphic setting, e.g.,
-          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
-          -- That won't work.
-        tycon = tyConAppTyCon res_ty
-
 cgOpApp (StgPrimOp primop) args res_ty = do
     dflags <- getDynFlags
     cmm_args <- getNonVoidArgAmodes args
     case emitPrimOp dflags primop cmm_args of
-        Nothing -> do  -- out-of-line
+        PrimopCmmEmit_External -> do  -- out-of-line
           let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
           emitCall (NativeNodeCall, NativeReturn) fun cmm_args
 
-        Just f  -- inline
+        PrimopCmmEmit_Raw f -> do
+          exprs <- f res_ty
+          emitReturn exprs
+
+        PrimopCmmEmit_IntoRegs f  -- inline
           | ReturnsPrim VoidRep <- result_info
           -> do f []
                 emitReturn []
@@ -158,8 +144,9 @@ cgPrimOp results op args = do
   dflags <- getDynFlags
   arg_exprs <- getNonVoidArgAmodes args
   case emitPrimOp dflags op arg_exprs of
-    Nothing -> panic "External prim op"
-    Just f -> f results
+    PrimopCmmEmit_External -> panic "External prim op"
+    PrimopCmmEmit_Raw _ -> panic "caller should handle TagToEnum themselves"
+    PrimopCmmEmit_IntoRegs f -> f results
 
 
 ------------------------------------------------------------------------
@@ -167,7 +154,10 @@ cgPrimOp results op args = do
 ------------------------------------------------------------------------
 
 shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool
-shouldInlinePrimOp dflags op args = isJust $ emitPrimOp dflags op args
+shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of
+  PrimopCmmEmit_External -> False
+  PrimopCmmEmit_IntoRegs _ -> True
+  PrimopCmmEmit_Raw _ -> True
 
 -- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use
 -- ByteOff (or some other fixed width signed type) to represent
@@ -180,130 +170,129 @@ shouldInlinePrimOp dflags op args = isJust $ emitPrimOp dflags op args
 -- 'newArray#'. This would lower the amount of code generated,
 -- hopefully without a performance impact (needs to be measured).
 
--- | The big function handling all the primops. The 'OpDest' function type
--- abstracts over a few common cases, and the "most manual" fallback.
+-- | The big function handling all the primops.
 --
 -- In the simple case, there is just one implementation, and we emit that.
 --
 -- In more complex cases, there is a foreign call (out of line) fallback. This
 -- might happen e.g. if there's enough static information, such as statically
 -- know arguments.
-dispatchPrimop
+emitPrimOp
   :: DynFlags
   -> PrimOp            -- ^ The primop
   -> [CmmExpr]         -- ^ The primop arguments
-  -> OpDest
-dispatchPrimop dflags = \case
+  -> PrimopCmmEmit
+emitPrimOp dflags = \case
   NewByteArrayOp_Char -> \case
     [(CmmLit (CmmInt n w))]
       | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone  $ \ [res] -> doNewByteArrayOp res (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone  $ \ [res] -> doNewByteArrayOp res (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   NewArrayOp -> \case
     [(CmmLit (CmmInt n w)), init]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
+      -> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
         [ (mkIntExpr dflags (fromInteger n),
            fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)
         , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),
            fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)
         ]
         (fromInteger n) init
-    _ -> OpDest_External
+    _ -> PrimopCmmEmit_External
 
   CopyArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      OpDest_AllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> OpDest_External
+      opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CopyMutableArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      OpDest_AllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> OpDest_External
+      opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CopyArrayArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      OpDest_AllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> OpDest_External
+      opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CopyMutableArrayArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      OpDest_AllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> OpDest_External
+      opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CloneArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CloneMutableArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   FreezeArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   ThawArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   NewSmallArrayOp -> \case
     [(CmmLit (CmmInt n w)), init]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] ->
+      -> opAllDone $ \ [res] ->
         doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
         [ (mkIntExpr dflags (fromInteger n),
            fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
         ]
         (fromInteger n) init
-    _ -> OpDest_External
+    _ -> PrimopCmmEmit_External
 
   CopySmallArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      OpDest_AllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> OpDest_External
+      opAllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CopySmallMutableArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      OpDest_AllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> OpDest_External
+      opAllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CloneSmallArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   CloneSmallMutableArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   FreezeSmallArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
   ThawSmallArrayOp -> \case
     [src, src_off, (CmmLit (CmmInt n w))]
       | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> OpDest_External
+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+    _ -> PrimopCmmEmit_External
 
 -- First we handle various awkward cases specially.
 
-  ParOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  ParOp -> \[arg] -> opAllDone $ \[res] -> do
     -- for now, just implement this in a C function
     -- later, we might want to inline it.
     emitCCall
@@ -311,7 +300,7 @@ dispatchPrimop dflags = \case
         (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
         [(baseExpr, AddrHint), (arg,AddrHint)]
 
-  SparkOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  SparkOp -> \[arg] -> opAllDone $ \[res] -> do
     -- returns the value of arg in res.  We're going to therefore
     -- refer to arg twice (once to pass to newSpark(), and once to
     -- assign to res), so put it in a temporary.
@@ -323,23 +312,23 @@ dispatchPrimop dflags = \case
         [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
     emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
 
-  GetCCSOfOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do
     let
       val
        | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
        | otherwise                      = CmmLit (zeroCLit dflags)
     emitAssign (CmmLocal res) val
 
-  GetCurrentCCSOp -> \[_] -> OpDest_AllDone $ \[res] -> do
+  GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) cccsExpr
 
-  MyThreadIdOp -> \[] -> OpDest_AllDone $ \[res] -> do
+  MyThreadIdOp -> \[] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) currentTSOExpr
 
-  ReadMutVarOp -> \[mutv] -> OpDest_AllDone $ \[res] -> do
+  ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
 
-  WriteMutVarOp -> \[mutv, var] -> OpDest_AllDone $ \res@[] -> do
+  WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do
     old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)
     emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
 
@@ -357,40 +346,40 @@ dispatchPrimop dflags = \case
 
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrBytes *)(a))->bytes
-  SizeofByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
 
 --  #define sizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrBytes *)(a))->bytes
-  SizeofMutableByteArrayOp -> dispatchPrimop dflags SizeofByteArrayOp
+  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp
 
 --  #define getSizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrBytes *)(a))->bytes
-  GetSizeofMutableByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
 
 
 --  #define touchzh(o)                  /* nothing */
-  TouchOp -> \args@[_] -> OpDest_AllDone $ \res@[] -> do
+  TouchOp -> \args@[_] -> opAllDone $ \res@[] -> do
     emitPrimCall res MO_Touch args
 
 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
-  ByteArrayContents_Char -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))
 
 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
-  StableNameToIntOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
 
-  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> OpDest_AllDone $ \[res] -> do
+  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
 
 --  #define addrToHValuezh(r,a) r=(P_)a
-  AddrToAnyOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) arg
 
 --  #define hvalueToAddrzh(r, a) r=(W_)a
-  AnyToAddrOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  AnyToAddrOp -> \[arg] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) arg
 
 {- Freezing arrays-of-ptrs requires changing an info table, for the
@@ -403,487 +392,487 @@ dispatchPrimop dflags = \case
 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);
 --        r = a;
 --      }
-  UnsafeFreezeArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  UnsafeFreezeArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emit $ catAGraphs
       [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
         mkAssign (CmmLocal res) arg ]
-  UnsafeFreezeArrayArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  UnsafeFreezeArrayArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emit $ catAGraphs
       [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
         mkAssign (CmmLocal res) arg ]
-  UnsafeFreezeSmallArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  UnsafeFreezeSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emit $ catAGraphs
       [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),
         mkAssign (CmmLocal res) arg ]
 
 --  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
-  UnsafeFreezeByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  UnsafeFreezeByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emitAssign (CmmLocal res) arg
 
 -- Reading/writing pointer arrays
 
-  ReadArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  ReadArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  IndexArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  IndexArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  WriteArrayOp -> \[obj, ix, v] -> OpDest_AllDone $ \[] -> do
+  WriteArrayOp -> \[obj, ix, v] -> opAllDone $ \[] -> do
     doWritePtrArrayOp obj ix v
 
-  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadPtrArrayOp res obj ix
-  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do
+  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do
     doWritePtrArrayOp obj ix v
-  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do
+  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do
     doWritePtrArrayOp obj ix v
-  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do
+  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do
     doWritePtrArrayOp obj ix v
-  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do
+  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do
     doWritePtrArrayOp obj ix v
 
-  ReadSmallArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  ReadSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadSmallPtrArrayOp res obj ix
-  IndexSmallArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do
+  IndexSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do
     doReadSmallPtrArrayOp res obj ix
-  WriteSmallArrayOp -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do
+  WriteSmallArrayOp -> \[obj,ix,v] -> opAllDone $ \[] -> do
     doWriteSmallPtrArrayOp obj ix v
 
 -- Getting the size of pointer arrays
 
-  SizeofArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg
       (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))
         (bWord dflags))
-  SizeofMutableArrayOp -> dispatchPrimop dflags SizeofArrayOp
-  SizeofArrayArrayOp -> dispatchPrimop dflags SizeofArrayOp
-  SizeofMutableArrayArrayOp -> dispatchPrimop dflags SizeofArrayOp
-  SizeofSmallArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do
+  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp
+  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp
+  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp
+  SizeofSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do
     emit $ mkAssign (CmmLocal res)
      (cmmLoadIndexW dflags arg
      (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))
         (bWord dflags))
 
-  SizeofSmallMutableArrayOp -> dispatchPrimop dflags SizeofSmallArrayOp
-  GetSizeofSmallMutableArrayOp -> dispatchPrimop dflags SizeofSmallArrayOp
+  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp
+  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp
 
 -- IndexXXXoffAddr
 
-  IndexOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
-  IndexOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
-  IndexOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  IndexOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  IndexOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  IndexOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing f32 res args
-  IndexOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing f64 res args
-  IndexOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  IndexOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
-  IndexOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
-  IndexOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
-  IndexOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing b64 res args
-  IndexOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
-  IndexOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
-  IndexOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
-  IndexOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do
+  IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing b64 res args
 
 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 
-  ReadOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
-  ReadOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
-  ReadOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  ReadOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  ReadOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  ReadOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing f32 res args
-  ReadOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing f64 res args
-  ReadOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing (bWord dflags) res args
-  ReadOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
-  ReadOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
-  ReadOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
-  ReadOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing b64 res args
-  ReadOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
-  ReadOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
-  ReadOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
-  ReadOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do
+  ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do
     doIndexOffAddrOp   Nothing b64 res args
 
 -- IndexXXXArray
 
-  IndexByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
-  IndexByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
-  IndexByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  IndexByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  IndexByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  IndexByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing f32 res args
-  IndexByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing f64 res args
-  IndexByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  IndexByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
-  IndexByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
-  IndexByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
-  IndexByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing b64  res args
-  IndexByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
-  IndexByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
-  IndexByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
-  IndexByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing b64  res args
 
 -- ReadXXXArray, identical to IndexXXXArray.
 
-  ReadByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
-  ReadByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
-  ReadByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  ReadByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  ReadByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  ReadByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing f32 res args
-  ReadByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing f64 res args
-  ReadByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing (bWord dflags) res args
-  ReadByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
-  ReadByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
-  ReadByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
-  ReadByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing b64  res args
-  ReadByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
-  ReadByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
-  ReadByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
-  ReadByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOp   Nothing b64  res args
 
 -- IndexWord8ArrayAsXXX
 
-  IndexByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
-  IndexByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
-  IndexByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  IndexByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  IndexByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  IndexByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing f32 b8 res args
-  IndexByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing f64 b8 res args
-  IndexByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  IndexByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
-  IndexByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
-  IndexByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing b64 b8 res args
-  IndexByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
-  IndexByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
-  IndexByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do
+  IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing b64 b8 res args
 
 -- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX
 
-  ReadByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
-  ReadByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
-  ReadByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  ReadByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  ReadByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  ReadByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing f32 b8 res args
-  ReadByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing f64 b8 res args
-  ReadByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
-  ReadByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
-  ReadByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
-  ReadByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing b64 b8 res args
-  ReadByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
-  ReadByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
-  ReadByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do
+  ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do
     doIndexByteArrayOpAs   Nothing b64 b8 res args
 
 -- WriteXXXoffAddr
 
-  WriteOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
-  WriteOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
-  WriteOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing (bWord dflags) res args
-  WriteOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing (bWord dflags) res args
-  WriteOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing (bWord dflags) res args
-  WriteOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing f32 res args
-  WriteOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing f64 res args
-  WriteOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing (bWord dflags) res args
-  WriteOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
-  WriteOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
-  WriteOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
-  WriteOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing b64 res args
-  WriteOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
-  WriteOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
-  WriteOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
-  WriteOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do
+  WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do
     doWriteOffAddrOp Nothing b64 res args
 
 -- WriteXXXArray
 
-  WriteByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
-  WriteByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
-  WriteByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing (bWord dflags) res args
-  WriteByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing (bWord dflags) res args
-  WriteByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing (bWord dflags) res args
-  WriteByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing f32 res args
-  WriteByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing f64 res args
-  WriteByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing (bWord dflags) res args
-  WriteByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
-  WriteByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
-  WriteByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
-  WriteByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b64 res args
-  WriteByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args
-  WriteByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
-  WriteByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
-  WriteByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b64 res args
 
 -- WriteInt8ArrayAsXXX
 
-  WriteByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
-  WriteByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
-  WriteByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
-  WriteByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
-  WriteByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
-  WriteByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
-  WriteByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do
+  WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do
     doWriteByteArrayOp Nothing b8 res args
 
 -- Copying and setting byte arrays
-  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do
+  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do
     doCopyByteArrayOp src src_off dst dst_off n
-  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do
+  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do
     doCopyMutableByteArrayOp src src_off dst dst_off n
-  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> OpDest_AllDone $ \[] -> do
+  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do
     doCopyByteArrayToAddrOp src src_off dst n
-  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> OpDest_AllDone $ \[] -> do
+  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do
     doCopyMutableByteArrayToAddrOp src src_off dst n
-  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do
+  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opAllDone $ \[] -> do
     doCopyAddrToByteArrayOp src dst dst_off n
-  SetByteArrayOp -> \[ba,off,len,c] -> OpDest_AllDone $ \[] -> do
+  SetByteArrayOp -> \[ba,off,len,c] -> opAllDone $ \[] -> do
     doSetByteArrayOp ba off len c
 
 -- Comparing byte arrays
-  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> OpDest_AllDone $ \[res] -> do
+  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opAllDone $ \[res] -> do
     doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n
 
-  BSwap16Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BSwap16Op -> \[w] -> opAllDone $ \[res] -> do
     emitBSwapCall res w W16
-  BSwap32Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BSwap32Op -> \[w] -> opAllDone $ \[res] -> do
     emitBSwapCall res w W32
-  BSwap64Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BSwap64Op -> \[w] -> opAllDone $ \[res] -> do
     emitBSwapCall res w W64
-  BSwapOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BSwapOp -> \[w] -> opAllDone $ \[res] -> do
     emitBSwapCall res w (wordWidth dflags)
 
-  BRev8Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BRev8Op -> \[w] -> opAllDone $ \[res] -> do
     emitBRevCall res w W8
-  BRev16Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BRev16Op -> \[w] -> opAllDone $ \[res] -> do
     emitBRevCall res w W16
-  BRev32Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BRev32Op -> \[w] -> opAllDone $ \[res] -> do
     emitBRevCall res w W32
-  BRev64Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BRev64Op -> \[w] -> opAllDone $ \[res] -> do
     emitBRevCall res w W64
-  BRevOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  BRevOp -> \[w] -> opAllDone $ \[res] -> do
     emitBRevCall res w (wordWidth dflags)
 
 -- Population count
-  PopCnt8Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do
     emitPopCntCall res w W8
-  PopCnt16Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  PopCnt16Op -> \[w] -> opAllDone $ \[res] -> do
     emitPopCntCall res w W16
-  PopCnt32Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  PopCnt32Op -> \[w] -> opAllDone $ \[res] -> do
     emitPopCntCall res w W32
-  PopCnt64Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do
     emitPopCntCall res w W64
-  PopCntOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  PopCntOp -> \[w] -> opAllDone $ \[res] -> do
     emitPopCntCall res w (wordWidth dflags)
 
 -- Parallel bit deposit
-  Pdep8Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPdepCall res src mask W8
-  Pdep16Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pdep16Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPdepCall res src mask W16
-  Pdep32Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pdep32Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPdepCall res src mask W32
-  Pdep64Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPdepCall res src mask W64
-  PdepOp -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPdepCall res src mask (wordWidth dflags)
 
 -- Parallel bit extract
-  Pext8Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPextCall res src mask W8
-  Pext16Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pext16Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPextCall res src mask W16
-  Pext32Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pext32Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPextCall res src mask W32
-  Pext64Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPextCall res src mask W64
-  PextOp -> \[src, mask] -> OpDest_AllDone $ \[res] -> do
+  PextOp -> \[src, mask] -> opAllDone $ \[res] -> do
     emitPextCall res src mask (wordWidth dflags)
 
 -- count leading zeros
-  Clz8Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Clz8Op -> \[w] -> opAllDone $ \[res] -> do
     emitClzCall res w W8
-  Clz16Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Clz16Op -> \[w] -> opAllDone $ \[res] -> do
     emitClzCall res w W16
-  Clz32Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Clz32Op -> \[w] -> opAllDone $ \[res] -> do
     emitClzCall res w W32
-  Clz64Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Clz64Op -> \[w] -> opAllDone $ \[res] -> do
     emitClzCall res w W64
-  ClzOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  ClzOp -> \[w] -> opAllDone $ \[res] -> do
     emitClzCall res w (wordWidth dflags)
 
 -- count trailing zeros
-  Ctz8Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Ctz8Op -> \[w] -> opAllDone $ \[res] -> do
     emitCtzCall res w W8
-  Ctz16Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Ctz16Op -> \[w] -> opAllDone $ \[res] -> do
     emitCtzCall res w W16
-  Ctz32Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Ctz32Op -> \[w] -> opAllDone $ \[res] -> do
     emitCtzCall res w W32
-  Ctz64Op -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Ctz64Op -> \[w] -> opAllDone $ \[res] -> do
     emitCtzCall res w W64
-  CtzOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  CtzOp -> \[w] -> opAllDone $ \[res] -> do
     emitCtzCall res w (wordWidth dflags)
 
 -- Unsigned int to floating point conversions
-  Word2FloatOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do
     emitPrimCall [res] (MO_UF_Conv W32) [w]
-  Word2DoubleOp -> \[w] -> OpDest_AllDone $ \[res] -> do
+  Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do
     emitPrimCall [res] (MO_UF_Conv W64) [w]
 
 -- SIMD primops
-  (VecBroadcastOp vcat n w) -> \[e] -> OpDest_AllDone $ \[res] -> do
+  (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do
     checkVecCompatibility dflags vcat n w
     doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res
    where
@@ -899,7 +888,7 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecPackOp vcat n w) -> \es -> OpDest_AllDone $ \[res] -> do
+  (VecPackOp vcat n w) -> \es -> opAllDone $ \[res] -> do
     checkVecCompatibility dflags vcat n w
     when (es `lengthIsNot` n) $
         panic "emitPrimOp: VecPackOp has wrong number of arguments"
@@ -917,7 +906,7 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecUnpackOp vcat n w) -> \[arg] -> OpDest_AllDone $ \res -> do
+  (VecUnpackOp vcat n w) -> \[arg] -> opAllDone $ \res -> do
     checkVecCompatibility dflags vcat n w
     when (res `lengthIsNot` n) $
         panic "emitPrimOp: VecUnpackOp has wrong number of results"
@@ -926,56 +915,56 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecInsertOp vcat n w) -> \[v,e,i] -> OpDest_AllDone $ \[res] -> do
+  (VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do
     checkVecCompatibility dflags vcat n w
     doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecIndexByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecIndexByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexByteArrayOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecReadByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecReadByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexByteArrayOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecWriteByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecWriteByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doWriteByteArrayOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecIndexOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecIndexOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexOffAddrOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecReadOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecReadOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexOffAddrOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecWriteOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecWriteOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doWriteOffAddrOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
-  (VecIndexScalarByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexByteArrayOpAs Nothing vecty ty res0 args
    where
@@ -985,7 +974,7 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecCmmCat vcat w
 
-  (VecReadScalarByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecReadScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexByteArrayOpAs Nothing vecty ty res0 args
    where
@@ -995,14 +984,14 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecCmmCat vcat w
 
-  (VecWriteScalarByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doWriteByteArrayOp Nothing ty res0 args
    where
     ty :: CmmType
     ty = vecCmmCat vcat w
 
-  (VecIndexScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexOffAddrOpAs Nothing vecty ty res0 args
    where
@@ -1012,7 +1001,7 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecCmmCat vcat w
 
-  (VecReadScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecReadScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doIndexOffAddrOpAs Nothing vecty ty res0 args
    where
@@ -1022,7 +1011,7 @@ dispatchPrimop dflags = \case
     ty :: CmmType
     ty = vecCmmCat vcat w
 
-  (VecWriteScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do
+  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do
     checkVecCompatibility dflags vcat n w
     doWriteOffAddrOp Nothing ty res0 args
    where
@@ -1030,412 +1019,425 @@ dispatchPrimop dflags = \case
     ty = vecCmmCat vcat w
 
 -- Prefetch
-  PrefetchByteArrayOp3         -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchByteArrayOp3         -> \args -> opAllDone $ \[] -> do
     doPrefetchByteArrayOp 3  args
-  PrefetchMutableByteArrayOp3  -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchMutableByteArrayOp3  -> \args -> opAllDone $ \[] -> do
     doPrefetchMutableByteArrayOp 3  args
-  PrefetchAddrOp3              -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchAddrOp3              -> \args -> opAllDone $ \[] -> do
     doPrefetchAddrOp  3  args
-  PrefetchValueOp3             -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchValueOp3             -> \args -> opAllDone $ \[] -> do
     doPrefetchValueOp 3 args
 
-  PrefetchByteArrayOp2         -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchByteArrayOp2         -> \args -> opAllDone $ \[] -> do
     doPrefetchByteArrayOp 2  args
-  PrefetchMutableByteArrayOp2  -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchMutableByteArrayOp2  -> \args -> opAllDone $ \[] -> do
     doPrefetchMutableByteArrayOp 2  args
-  PrefetchAddrOp2              -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchAddrOp2              -> \args -> opAllDone $ \[] -> do
     doPrefetchAddrOp 2  args
-  PrefetchValueOp2             -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchValueOp2             -> \args -> opAllDone $ \[] -> do
     doPrefetchValueOp 2 args
-  PrefetchByteArrayOp1         -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchByteArrayOp1         -> \args -> opAllDone $ \[] -> do
     doPrefetchByteArrayOp 1  args
-  PrefetchMutableByteArrayOp1  -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchMutableByteArrayOp1  -> \args -> opAllDone $ \[] -> do
     doPrefetchMutableByteArrayOp 1  args
-  PrefetchAddrOp1              -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchAddrOp1              -> \args -> opAllDone $ \[] -> do
     doPrefetchAddrOp 1  args
-  PrefetchValueOp1             -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchValueOp1             -> \args -> opAllDone $ \[] -> do
     doPrefetchValueOp 1 args
 
-  PrefetchByteArrayOp0         -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchByteArrayOp0         -> \args -> opAllDone $ \[] -> do
     doPrefetchByteArrayOp 0  args
-  PrefetchMutableByteArrayOp0  -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchMutableByteArrayOp0  -> \args -> opAllDone $ \[] -> do
     doPrefetchMutableByteArrayOp 0  args
-  PrefetchAddrOp0              -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchAddrOp0              -> \args -> opAllDone $ \[] -> do
     doPrefetchAddrOp 0  args
-  PrefetchValueOp0             -> \args -> OpDest_AllDone $ \[] -> do
+  PrefetchValueOp0             -> \args -> opAllDone $ \[] -> do
     doPrefetchValueOp 0 args
 
 -- Atomic read-modify-write
-  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do
+  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
     doAtomicRMW res AMO_Add mba ix (bWord dflags) n
-  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do
+  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
     doAtomicRMW res AMO_Sub mba ix (bWord dflags) n
-  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do
+  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
     doAtomicRMW res AMO_And mba ix (bWord dflags) n
-  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do
+  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
     doAtomicRMW res AMO_Nand mba ix (bWord dflags) n
-  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do
+  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
     doAtomicRMW res AMO_Or mba ix (bWord dflags) n
-  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do
+  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
     doAtomicRMW res AMO_Xor mba ix (bWord dflags) n
-  AtomicReadByteArrayOp_Int -> \[mba, ix] -> OpDest_AllDone $ \[res] -> do
+  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do
     doAtomicReadByteArray res mba ix (bWord dflags)
-  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> OpDest_AllDone $ \[] -> do
+  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do
     doAtomicWriteByteArray mba ix (bWord dflags) val
-  CasByteArrayOp_Int -> \[mba, ix, old, new] -> OpDest_AllDone $ \[res] -> do
+  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do
     doCasByteArray res mba ix (bWord dflags) old new
 
 -- The rest just translate straightforwardly
 
-  Int2WordOp      -> \_ -> OpDest_Nop
-  Word2IntOp      -> \_ -> OpDest_Nop
-  Int2AddrOp      -> \_ -> OpDest_Nop
-  Addr2IntOp      -> \_ -> OpDest_Nop
-  ChrOp           -> \_ -> OpDest_Nop  -- Int# and Char# are rep'd the same
-  OrdOp           -> \_ -> OpDest_Nop
-
-  Narrow8IntOp   -> \_ -> OpDest_Narrow (MO_SS_Conv, W8)
-  Narrow16IntOp  -> \_ -> OpDest_Narrow (MO_SS_Conv, W16)
-  Narrow32IntOp  -> \_ -> OpDest_Narrow (MO_SS_Conv, W32)
-  Narrow8WordOp  -> \_ -> OpDest_Narrow (MO_UU_Conv, W8)
-  Narrow16WordOp -> \_ -> OpDest_Narrow (MO_UU_Conv, W16)
-  Narrow32WordOp -> \_ -> OpDest_Narrow (MO_UU_Conv, W32)
-
-  DoublePowerOp  -> \_ -> OpDest_Callish MO_F64_Pwr
-  DoubleSinOp    -> \_ -> OpDest_Callish MO_F64_Sin
-  DoubleCosOp    -> \_ -> OpDest_Callish MO_F64_Cos
-  DoubleTanOp    -> \_ -> OpDest_Callish MO_F64_Tan
-  DoubleSinhOp   -> \_ -> OpDest_Callish MO_F64_Sinh
-  DoubleCoshOp   -> \_ -> OpDest_Callish MO_F64_Cosh
-  DoubleTanhOp   -> \_ -> OpDest_Callish MO_F64_Tanh
-  DoubleAsinOp   -> \_ -> OpDest_Callish MO_F64_Asin
-  DoubleAcosOp   -> \_ -> OpDest_Callish MO_F64_Acos
-  DoubleAtanOp   -> \_ -> OpDest_Callish MO_F64_Atan
-  DoubleAsinhOp  -> \_ -> OpDest_Callish MO_F64_Asinh
-  DoubleAcoshOp  -> \_ -> OpDest_Callish MO_F64_Acosh
-  DoubleAtanhOp  -> \_ -> OpDest_Callish MO_F64_Atanh
-  DoubleLogOp    -> \_ -> OpDest_Callish MO_F64_Log
-  DoubleLog1POp  -> \_ -> OpDest_Callish MO_F64_Log1P
-  DoubleExpOp    -> \_ -> OpDest_Callish MO_F64_Exp
-  DoubleExpM1Op  -> \_ -> OpDest_Callish MO_F64_ExpM1
-  DoubleSqrtOp   -> \_ -> OpDest_Callish MO_F64_Sqrt
-
-  FloatPowerOp   -> \_ -> OpDest_Callish MO_F32_Pwr
-  FloatSinOp     -> \_ -> OpDest_Callish MO_F32_Sin
-  FloatCosOp     -> \_ -> OpDest_Callish MO_F32_Cos
-  FloatTanOp     -> \_ -> OpDest_Callish MO_F32_Tan
-  FloatSinhOp    -> \_ -> OpDest_Callish MO_F32_Sinh
-  FloatCoshOp    -> \_ -> OpDest_Callish MO_F32_Cosh
-  FloatTanhOp    -> \_ -> OpDest_Callish MO_F32_Tanh
-  FloatAsinOp    -> \_ -> OpDest_Callish MO_F32_Asin
-  FloatAcosOp    -> \_ -> OpDest_Callish MO_F32_Acos
-  FloatAtanOp    -> \_ -> OpDest_Callish MO_F32_Atan
-  FloatAsinhOp   -> \_ -> OpDest_Callish MO_F32_Asinh
-  FloatAcoshOp   -> \_ -> OpDest_Callish MO_F32_Acosh
-  FloatAtanhOp   -> \_ -> OpDest_Callish MO_F32_Atanh
-  FloatLogOp     -> \_ -> OpDest_Callish MO_F32_Log
-  FloatLog1POp   -> \_ -> OpDest_Callish MO_F32_Log1P
-  FloatExpOp     -> \_ -> OpDest_Callish MO_F32_Exp
-  FloatExpM1Op   -> \_ -> OpDest_Callish MO_F32_ExpM1
-  FloatSqrtOp    -> \_ -> OpDest_Callish MO_F32_Sqrt
+  Int2WordOp      -> \args -> opNop args
+  Word2IntOp      -> \args -> opNop args
+  Int2AddrOp      -> \args -> opNop args
+  Addr2IntOp      -> \args -> opNop args
+  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same
+  OrdOp           -> \args -> opNop args
+
+  Narrow8IntOp   -> \args -> opNarrow dflags args (MO_SS_Conv, W8)
+  Narrow16IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W16)
+  Narrow32IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W32)
+  Narrow8WordOp  -> \args -> opNarrow dflags args (MO_UU_Conv, W8)
+  Narrow16WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W16)
+  Narrow32WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W32)
+
+  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr
+  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin
+  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos
+  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan
+  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh
+  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh
+  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh
+  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin
+  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos
+  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan
+  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh
+  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh
+  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh
+  DoubleLogOp    -> \args -> opCallish args MO_F64_Log
+  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P
+  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp
+  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1
+  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt
+
+  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr
+  FloatSinOp     -> \args -> opCallish args MO_F32_Sin
+  FloatCosOp     -> \args -> opCallish args MO_F32_Cos
+  FloatTanOp     -> \args -> opCallish args MO_F32_Tan
+  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh
+  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh
+  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh
+  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin
+  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos
+  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan
+  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh
+  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh
+  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh
+  FloatLogOp     -> \args -> opCallish args MO_F32_Log
+  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P
+  FloatExpOp     -> \args -> opCallish args MO_F32_Exp
+  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1
+  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt
 
 -- Native word signless ops
 
-  IntAddOp       -> \_ -> OpDest_Translate (mo_wordAdd dflags)
-  IntSubOp       -> \_ -> OpDest_Translate (mo_wordSub dflags)
-  WordAddOp      -> \_ -> OpDest_Translate (mo_wordAdd dflags)
-  WordSubOp      -> \_ -> OpDest_Translate (mo_wordSub dflags)
-  AddrAddOp      -> \_ -> OpDest_Translate (mo_wordAdd dflags)
-  AddrSubOp      -> \_ -> OpDest_Translate (mo_wordSub dflags)
-
-  IntEqOp        -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  IntNeOp        -> \_ -> OpDest_Translate (mo_wordNe dflags)
-  WordEqOp       -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  WordNeOp       -> \_ -> OpDest_Translate (mo_wordNe dflags)
-  AddrEqOp       -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  AddrNeOp       -> \_ -> OpDest_Translate (mo_wordNe dflags)
-
-  AndOp          -> \_ -> OpDest_Translate (mo_wordAnd dflags)
-  OrOp           -> \_ -> OpDest_Translate (mo_wordOr dflags)
-  XorOp          -> \_ -> OpDest_Translate (mo_wordXor dflags)
-  NotOp          -> \_ -> OpDest_Translate (mo_wordNot dflags)
-  SllOp          -> \_ -> OpDest_Translate (mo_wordShl dflags)
-  SrlOp          -> \_ -> OpDest_Translate (mo_wordUShr dflags)
-
-  AddrRemOp      -> \_ -> OpDest_Translate (mo_wordURem dflags)
+  IntAddOp       -> \args -> opTranslate args (mo_wordAdd dflags)
+  IntSubOp       -> \args -> opTranslate args (mo_wordSub dflags)
+  WordAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)
+  WordSubOp      -> \args -> opTranslate args (mo_wordSub dflags)
+  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)
+  AddrSubOp      -> \args -> opTranslate args (mo_wordSub dflags)
+
+  IntEqOp        -> \args -> opTranslate args (mo_wordEq dflags)
+  IntNeOp        -> \args -> opTranslate args (mo_wordNe dflags)
+  WordEqOp       -> \args -> opTranslate args (mo_wordEq dflags)
+  WordNeOp       -> \args -> opTranslate args (mo_wordNe dflags)
+  AddrEqOp       -> \args -> opTranslate args (mo_wordEq dflags)
+  AddrNeOp       -> \args -> opTranslate args (mo_wordNe dflags)
+
+  AndOp          -> \args -> opTranslate args (mo_wordAnd dflags)
+  OrOp           -> \args -> opTranslate args (mo_wordOr dflags)
+  XorOp          -> \args -> opTranslate args (mo_wordXor dflags)
+  NotOp          -> \args -> opTranslate args (mo_wordNot dflags)
+  SllOp          -> \args -> opTranslate args (mo_wordShl dflags)
+  SrlOp          -> \args -> opTranslate args (mo_wordUShr dflags)
+
+  AddrRemOp      -> \args -> opTranslate args (mo_wordURem dflags)
 
 -- Native word signed ops
 
-  IntMulOp        -> \_ -> OpDest_Translate (mo_wordMul dflags)
-  IntMulMayOfloOp -> \_ -> OpDest_Translate (MO_S_MulMayOflo (wordWidth dflags))
-  IntQuotOp       -> \_ -> OpDest_Translate (mo_wordSQuot dflags)
-  IntRemOp        -> \_ -> OpDest_Translate (mo_wordSRem dflags)
-  IntNegOp        -> \_ -> OpDest_Translate (mo_wordSNeg dflags)
-
-  IntGeOp        -> \_ -> OpDest_Translate (mo_wordSGe dflags)
-  IntLeOp        -> \_ -> OpDest_Translate (mo_wordSLe dflags)
-  IntGtOp        -> \_ -> OpDest_Translate (mo_wordSGt dflags)
-  IntLtOp        -> \_ -> OpDest_Translate (mo_wordSLt dflags)
-
-  AndIOp         -> \_ -> OpDest_Translate (mo_wordAnd dflags)
-  OrIOp          -> \_ -> OpDest_Translate (mo_wordOr dflags)
-  XorIOp         -> \_ -> OpDest_Translate (mo_wordXor dflags)
-  NotIOp         -> \_ -> OpDest_Translate (mo_wordNot dflags)
-  ISllOp         -> \_ -> OpDest_Translate (mo_wordShl dflags)
-  ISraOp         -> \_ -> OpDest_Translate (mo_wordSShr dflags)
-  ISrlOp         -> \_ -> OpDest_Translate (mo_wordUShr dflags)
+  IntMulOp        -> \args -> opTranslate args (mo_wordMul dflags)
+  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth dflags))
+  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot dflags)
+  IntRemOp        -> \args -> opTranslate args (mo_wordSRem dflags)
+  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg dflags)
+
+  IntGeOp        -> \args -> opTranslate args (mo_wordSGe dflags)
+  IntLeOp        -> \args -> opTranslate args (mo_wordSLe dflags)
+  IntGtOp        -> \args -> opTranslate args (mo_wordSGt dflags)
+  IntLtOp        -> \args -> opTranslate args (mo_wordSLt dflags)
+
+  AndIOp         -> \args -> opTranslate args (mo_wordAnd dflags)
+  OrIOp          -> \args -> opTranslate args (mo_wordOr dflags)
+  XorIOp         -> \args -> opTranslate args (mo_wordXor dflags)
+  NotIOp         -> \args -> opTranslate args (mo_wordNot dflags)
+  ISllOp         -> \args -> opTranslate args (mo_wordShl dflags)
+  ISraOp         -> \args -> opTranslate args (mo_wordSShr dflags)
+  ISrlOp         -> \args -> opTranslate args (mo_wordUShr dflags)
 
 -- Native word unsigned ops
 
-  WordGeOp       -> \_ -> OpDest_Translate (mo_wordUGe dflags)
-  WordLeOp       -> \_ -> OpDest_Translate (mo_wordULe dflags)
-  WordGtOp       -> \_ -> OpDest_Translate (mo_wordUGt dflags)
-  WordLtOp       -> \_ -> OpDest_Translate (mo_wordULt dflags)
+  WordGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)
+  WordLeOp       -> \args -> opTranslate args (mo_wordULe dflags)
+  WordGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)
+  WordLtOp       -> \args -> opTranslate args (mo_wordULt dflags)
 
-  WordMulOp      -> \_ -> OpDest_Translate (mo_wordMul dflags)
-  WordQuotOp     -> \_ -> OpDest_Translate (mo_wordUQuot dflags)
-  WordRemOp      -> \_ -> OpDest_Translate (mo_wordURem dflags)
+  WordMulOp      -> \args -> opTranslate args (mo_wordMul dflags)
+  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot dflags)
+  WordRemOp      -> \args -> opTranslate args (mo_wordURem dflags)
 
-  AddrGeOp       -> \_ -> OpDest_Translate (mo_wordUGe dflags)
-  AddrLeOp       -> \_ -> OpDest_Translate (mo_wordULe dflags)
-  AddrGtOp       -> \_ -> OpDest_Translate (mo_wordUGt dflags)
-  AddrLtOp       -> \_ -> OpDest_Translate (mo_wordULt dflags)
+  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)
+  AddrLeOp       -> \args -> opTranslate args (mo_wordULe dflags)
+  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)
+  AddrLtOp       -> \args -> opTranslate args (mo_wordULt dflags)
 
 -- Int8# signed ops
 
-  Int8Extend     -> \_ -> OpDest_Translate (MO_SS_Conv W8 (wordWidth dflags))
-  Int8Narrow     -> \_ -> OpDest_Translate (MO_SS_Conv (wordWidth dflags) W8)
-  Int8NegOp      -> \_ -> OpDest_Translate (MO_S_Neg W8)
-  Int8AddOp      -> \_ -> OpDest_Translate (MO_Add W8)
-  Int8SubOp      -> \_ -> OpDest_Translate (MO_Sub W8)
-  Int8MulOp      -> \_ -> OpDest_Translate (MO_Mul W8)
-  Int8QuotOp     -> \_ -> OpDest_Translate (MO_S_Quot W8)
-  Int8RemOp      -> \_ -> OpDest_Translate (MO_S_Rem W8)
-
-  Int8EqOp       -> \_ -> OpDest_Translate (MO_Eq W8)
-  Int8GeOp       -> \_ -> OpDest_Translate (MO_S_Ge W8)
-  Int8GtOp       -> \_ -> OpDest_Translate (MO_S_Gt W8)
-  Int8LeOp       -> \_ -> OpDest_Translate (MO_S_Le W8)
-  Int8LtOp       -> \_ -> OpDest_Translate (MO_S_Lt W8)
-  Int8NeOp       -> \_ -> OpDest_Translate (MO_Ne W8)
+  Int8Extend     -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth dflags))
+  Int8Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W8)
+  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)
+  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)
+  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)
+  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)
+  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)
+  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)
+
+  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)
+  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)
+  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)
+  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)
+  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)
+  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)
 
 -- Word8# unsigned ops
 
-  Word8Extend     -> \_ -> OpDest_Translate (MO_UU_Conv W8 (wordWidth dflags))
-  Word8Narrow     -> \_ -> OpDest_Translate (MO_UU_Conv (wordWidth dflags) W8)
-  Word8NotOp      -> \_ -> OpDest_Translate (MO_Not W8)
-  Word8AddOp      -> \_ -> OpDest_Translate (MO_Add W8)
-  Word8SubOp      -> \_ -> OpDest_Translate (MO_Sub W8)
-  Word8MulOp      -> \_ -> OpDest_Translate (MO_Mul W8)
-  Word8QuotOp     -> \_ -> OpDest_Translate (MO_U_Quot W8)
-  Word8RemOp      -> \_ -> OpDest_Translate (MO_U_Rem W8)
-
-  Word8EqOp       -> \_ -> OpDest_Translate (MO_Eq W8)
-  Word8GeOp       -> \_ -> OpDest_Translate (MO_U_Ge W8)
-  Word8GtOp       -> \_ -> OpDest_Translate (MO_U_Gt W8)
-  Word8LeOp       -> \_ -> OpDest_Translate (MO_U_Le W8)
-  Word8LtOp       -> \_ -> OpDest_Translate (MO_U_Lt W8)
-  Word8NeOp       -> \_ -> OpDest_Translate (MO_Ne W8)
+  Word8Extend     -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth dflags))
+  Word8Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W8)
+  Word8NotOp      -> \args -> opTranslate args (MO_Not W8)
+  Word8AddOp      -> \args -> opTranslate args (MO_Add W8)
+  Word8SubOp      -> \args -> opTranslate args (MO_Sub W8)
+  Word8MulOp      -> \args -> opTranslate args (MO_Mul W8)
+  Word8QuotOp     -> \args -> opTranslate args (MO_U_Quot W8)
+  Word8RemOp      -> \args -> opTranslate args (MO_U_Rem W8)
+
+  Word8EqOp       -> \args -> opTranslate args (MO_Eq W8)
+  Word8GeOp       -> \args -> opTranslate args (MO_U_Ge W8)
+  Word8GtOp       -> \args -> opTranslate args (MO_U_Gt W8)
+  Word8LeOp       -> \args -> opTranslate args (MO_U_Le W8)
+  Word8LtOp       -> \args -> opTranslate args (MO_U_Lt W8)
+  Word8NeOp       -> \args -> opTranslate args (MO_Ne W8)
 
 -- Int16# signed ops
 
-  Int16Extend     -> \_ -> OpDest_Translate (MO_SS_Conv W16 (wordWidth dflags))
-  Int16Narrow     -> \_ -> OpDest_Translate (MO_SS_Conv (wordWidth dflags) W16)
-  Int16NegOp      -> \_ -> OpDest_Translate (MO_S_Neg W16)
-  Int16AddOp      -> \_ -> OpDest_Translate (MO_Add W16)
-  Int16SubOp      -> \_ -> OpDest_Translate (MO_Sub W16)
-  Int16MulOp      -> \_ -> OpDest_Translate (MO_Mul W16)
-  Int16QuotOp     -> \_ -> OpDest_Translate (MO_S_Quot W16)
-  Int16RemOp      -> \_ -> OpDest_Translate (MO_S_Rem W16)
-
-  Int16EqOp       -> \_ -> OpDest_Translate (MO_Eq W16)
-  Int16GeOp       -> \_ -> OpDest_Translate (MO_S_Ge W16)
-  Int16GtOp       -> \_ -> OpDest_Translate (MO_S_Gt W16)
-  Int16LeOp       -> \_ -> OpDest_Translate (MO_S_Le W16)
-  Int16LtOp       -> \_ -> OpDest_Translate (MO_S_Lt W16)
-  Int16NeOp       -> \_ -> OpDest_Translate (MO_Ne W16)
+  Int16Extend     -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth dflags))
+  Int16Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W16)
+  Int16NegOp      -> \args -> opTranslate args (MO_S_Neg W16)
+  Int16AddOp      -> \args -> opTranslate args (MO_Add W16)
+  Int16SubOp      -> \args -> opTranslate args (MO_Sub W16)
+  Int16MulOp      -> \args -> opTranslate args (MO_Mul W16)
+  Int16QuotOp     -> \args -> opTranslate args (MO_S_Quot W16)
+  Int16RemOp      -> \args -> opTranslate args (MO_S_Rem W16)
+
+  Int16EqOp       -> \args -> opTranslate args (MO_Eq W16)
+  Int16GeOp       -> \args -> opTranslate args (MO_S_Ge W16)
+  Int16GtOp       -> \args -> opTranslate args (MO_S_Gt W16)
+  Int16LeOp       -> \args -> opTranslate args (MO_S_Le W16)
+  Int16LtOp       -> \args -> opTranslate args (MO_S_Lt W16)
+  Int16NeOp       -> \args -> opTranslate args (MO_Ne W16)
 
 -- Word16# unsigned ops
 
-  Word16Extend     -> \_ -> OpDest_Translate (MO_UU_Conv W16 (wordWidth dflags))
-  Word16Narrow     -> \_ -> OpDest_Translate (MO_UU_Conv (wordWidth dflags) W16)
-  Word16NotOp      -> \_ -> OpDest_Translate (MO_Not W16)
-  Word16AddOp      -> \_ -> OpDest_Translate (MO_Add W16)
-  Word16SubOp      -> \_ -> OpDest_Translate (MO_Sub W16)
-  Word16MulOp      -> \_ -> OpDest_Translate (MO_Mul W16)
-  Word16QuotOp     -> \_ -> OpDest_Translate (MO_U_Quot W16)
-  Word16RemOp      -> \_ -> OpDest_Translate (MO_U_Rem W16)
-
-  Word16EqOp       -> \_ -> OpDest_Translate (MO_Eq W16)
-  Word16GeOp       -> \_ -> OpDest_Translate (MO_U_Ge W16)
-  Word16GtOp       -> \_ -> OpDest_Translate (MO_U_Gt W16)
-  Word16LeOp       -> \_ -> OpDest_Translate (MO_U_Le W16)
-  Word16LtOp       -> \_ -> OpDest_Translate (MO_U_Lt W16)
-  Word16NeOp       -> \_ -> OpDest_Translate (MO_Ne W16)
+  Word16Extend     -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth dflags))
+  Word16Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W16)
+  Word16NotOp      -> \args -> opTranslate args (MO_Not W16)
+  Word16AddOp      -> \args -> opTranslate args (MO_Add W16)
+  Word16SubOp      -> \args -> opTranslate args (MO_Sub W16)
+  Word16MulOp      -> \args -> opTranslate args (MO_Mul W16)
+  Word16QuotOp     -> \args -> opTranslate args (MO_U_Quot W16)
+  Word16RemOp      -> \args -> opTranslate args (MO_U_Rem W16)
+
+  Word16EqOp       -> \args -> opTranslate args (MO_Eq W16)
+  Word16GeOp       -> \args -> opTranslate args (MO_U_Ge W16)
+  Word16GtOp       -> \args -> opTranslate args (MO_U_Gt W16)
+  Word16LeOp       -> \args -> opTranslate args (MO_U_Le W16)
+  Word16LtOp       -> \args -> opTranslate args (MO_U_Lt W16)
+  Word16NeOp       -> \args -> opTranslate args (MO_Ne W16)
 
 -- Char# ops
 
-  CharEqOp       -> \_ -> OpDest_Translate (MO_Eq (wordWidth dflags))
-  CharNeOp       -> \_ -> OpDest_Translate (MO_Ne (wordWidth dflags))
-  CharGeOp       -> \_ -> OpDest_Translate (MO_U_Ge (wordWidth dflags))
-  CharLeOp       -> \_ -> OpDest_Translate (MO_U_Le (wordWidth dflags))
-  CharGtOp       -> \_ -> OpDest_Translate (MO_U_Gt (wordWidth dflags))
-  CharLtOp       -> \_ -> OpDest_Translate (MO_U_Lt (wordWidth dflags))
+  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth dflags))
+  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth dflags))
+  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth dflags))
+  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth dflags))
+  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth dflags))
+  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth dflags))
 
 -- Double ops
 
-  DoubleEqOp     -> \_ -> OpDest_Translate (MO_F_Eq W64)
-  DoubleNeOp     -> \_ -> OpDest_Translate (MO_F_Ne W64)
-  DoubleGeOp     -> \_ -> OpDest_Translate (MO_F_Ge W64)
-  DoubleLeOp     -> \_ -> OpDest_Translate (MO_F_Le W64)
-  DoubleGtOp     -> \_ -> OpDest_Translate (MO_F_Gt W64)
-  DoubleLtOp     -> \_ -> OpDest_Translate (MO_F_Lt W64)
+  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)
+  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)
+  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)
+  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)
+  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)
+  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)
 
-  DoubleAddOp    -> \_ -> OpDest_Translate (MO_F_Add W64)
-  DoubleSubOp    -> \_ -> OpDest_Translate (MO_F_Sub W64)
-  DoubleMulOp    -> \_ -> OpDest_Translate (MO_F_Mul W64)
-  DoubleDivOp    -> \_ -> OpDest_Translate (MO_F_Quot W64)
-  DoubleNegOp    -> \_ -> OpDest_Translate (MO_F_Neg W64)
+  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)
+  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)
+  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)
+  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)
+  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)
 
 -- Float ops
 
-  FloatEqOp     -> \_ -> OpDest_Translate (MO_F_Eq W32)
-  FloatNeOp     -> \_ -> OpDest_Translate (MO_F_Ne W32)
-  FloatGeOp     -> \_ -> OpDest_Translate (MO_F_Ge W32)
-  FloatLeOp     -> \_ -> OpDest_Translate (MO_F_Le W32)
-  FloatGtOp     -> \_ -> OpDest_Translate (MO_F_Gt W32)
-  FloatLtOp     -> \_ -> OpDest_Translate (MO_F_Lt W32)
+  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)
+  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)
+  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)
+  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)
+  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)
+  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)
 
-  FloatAddOp    -> \_ -> OpDest_Translate (MO_F_Add  W32)
-  FloatSubOp    -> \_ -> OpDest_Translate (MO_F_Sub  W32)
-  FloatMulOp    -> \_ -> OpDest_Translate (MO_F_Mul  W32)
-  FloatDivOp    -> \_ -> OpDest_Translate (MO_F_Quot W32)
-  FloatNegOp    -> \_ -> OpDest_Translate (MO_F_Neg  W32)
+  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)
+  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)
+  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)
+  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)
+  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)
 
 -- Vector ops
 
-  (VecAddOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Add  n w)
-  (VecSubOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Sub  n w)
-  (VecMulOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Mul  n w)
-  (VecDivOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Quot n w)
+  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)
+  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)
+  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)
+  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)
   (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"
   (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"
-  (VecNegOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Neg  n w)
+  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)
 
-  (VecAddOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Add   n w)
-  (VecSubOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Sub   n w)
-  (VecMulOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Mul   n w)
+  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)
+  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)
+  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)
   (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"
-  (VecQuotOp IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Quot n w)
-  (VecRemOp  IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Rem  n w)
-  (VecNegOp  IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Neg  n w)
+  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)
+  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)
+  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)
 
-  (VecAddOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Add   n w)
-  (VecSubOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Sub   n w)
-  (VecMulOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Mul   n w)
+  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)
+  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)
+  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)
   (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"
-  (VecQuotOp WordVec n w) -> \_ -> OpDest_Translate (MO_VU_Quot n w)
-  (VecRemOp  WordVec n w) -> \_ -> OpDest_Translate (MO_VU_Rem  n w)
+  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)
+  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)
   (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"
 
 -- Conversions
 
-  Int2DoubleOp   -> \_ -> OpDest_Translate (MO_SF_Conv (wordWidth dflags) W64)
-  Double2IntOp   -> \_ -> OpDest_Translate (MO_FS_Conv W64 (wordWidth dflags))
+  Int2DoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W64)
+  Double2IntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth dflags))
 
-  Int2FloatOp    -> \_ -> OpDest_Translate (MO_SF_Conv (wordWidth dflags) W32)
-  Float2IntOp    -> \_ -> OpDest_Translate (MO_FS_Conv W32 (wordWidth dflags))
+  Int2FloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W32)
+  Float2IntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth dflags))
 
-  Float2DoubleOp -> \_ -> OpDest_Translate (MO_FF_Conv W32 W64)
-  Double2FloatOp -> \_ -> OpDest_Translate (MO_FF_Conv W64 W32)
+  Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)
+  Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)
 
 -- Word comparisons masquerading as more exotic things.
 
-  SameMutVarOp            -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  SameMVarOp              -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  SameMutableArrayOp      -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  SameMutableByteArrayOp  -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  SameMutableArrayArrayOp -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  SameSmallMutableArrayOp -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  SameTVarOp              -> \_ -> OpDest_Translate (mo_wordEq dflags)
-  EqStablePtrOp           -> \_ -> OpDest_Translate (mo_wordEq dflags)
+  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq dflags)
+  SameMVarOp              -> \args -> opTranslate args (mo_wordEq dflags)
+  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq dflags)
+  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq dflags)
+  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq dflags)
+  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags)
+  SameTVarOp              -> \args -> opTranslate args (mo_wordEq dflags)
+  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq dflags)
 -- See Note [Comparing stable names]
-  EqStableNameOp          -> \_ -> OpDest_Translate (mo_wordEq dflags)
+  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq dflags)
 
-  IntQuotRemOp -> \args -> OpDest_CallishHandledLater $
+  IntQuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_S_QuotRem  (wordWidth dflags))
     else Right (genericIntQuotRemOp (wordWidth dflags))
 
-  Int8QuotRemOp -> \args -> OpDest_CallishHandledLater $
+  Int8QuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_S_QuotRem W8)
     else Right (genericIntQuotRemOp W8)
 
-  Int16QuotRemOp -> \args -> OpDest_CallishHandledLater $
+  Int16QuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_S_QuotRem W16)
     else Right (genericIntQuotRemOp W16)
 
-  WordQuotRemOp -> \args -> OpDest_CallishHandledLater $
+  WordQuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_U_QuotRem  (wordWidth dflags))
     else Right (genericWordQuotRemOp (wordWidth dflags))
 
-  WordQuotRem2Op -> \_ -> OpDest_CallishHandledLater $
+  WordQuotRem2Op -> \args -> opCallishHandledLater args $
     if (ncg && (x86ish || ppc)) || llvm
     then Left (MO_U_QuotRem2 (wordWidth dflags))
     else Right (genericWordQuotRem2Op dflags)
 
-  Word8QuotRemOp -> \args -> OpDest_CallishHandledLater $
+  Word8QuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_U_QuotRem W8)
     else Right (genericWordQuotRemOp W8)
 
-  Word16QuotRemOp -> \args -> OpDest_CallishHandledLater $
+  Word16QuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_U_QuotRem W16)
     else Right (genericWordQuotRemOp W16)
 
-  WordAdd2Op -> \_ -> OpDest_CallishHandledLater $
+  WordAdd2Op -> \args -> opCallishHandledLater args $
     if (ncg && (x86ish || ppc)) || llvm
     then Left (MO_Add2       (wordWidth dflags))
     else Right genericWordAdd2Op
 
-  WordAddCOp -> \_ -> OpDest_CallishHandledLater $
+  WordAddCOp -> \args -> opCallishHandledLater args $
     if (ncg && (x86ish || ppc)) || llvm
     then Left (MO_AddWordC   (wordWidth dflags))
     else Right genericWordAddCOp
 
-  WordSubCOp -> \_ -> OpDest_CallishHandledLater $
+  WordSubCOp -> \args -> opCallishHandledLater args $
     if (ncg && (x86ish || ppc)) || llvm
     then Left (MO_SubWordC   (wordWidth dflags))
     else Right genericWordSubCOp
 
-  IntAddCOp -> \_ -> OpDest_CallishHandledLater $
+  IntAddCOp -> \args -> opCallishHandledLater args $
     if (ncg && (x86ish || ppc)) || llvm
     then Left (MO_AddIntC    (wordWidth dflags))
     else Right genericIntAddCOp
 
-  IntSubCOp -> \_ -> OpDest_CallishHandledLater $
+  IntSubCOp -> \args -> opCallishHandledLater args $
     if (ncg && (x86ish || ppc)) || llvm
     then Left (MO_SubIntC    (wordWidth dflags))
     else Right genericIntSubCOp
 
-  WordMul2Op -> \_ -> OpDest_CallishHandledLater $
+  WordMul2Op -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) || llvm
     then Left (MO_U_Mul2     (wordWidth dflags))
     else Right genericWordMul2Op
-  FloatFabsOp -> \_ -> OpDest_CallishHandledLater $
+
+  FloatFabsOp -> \args -> opCallishHandledLater args $
     if (ncg && x86ish || ppc) || llvm
     then Left MO_F32_Fabs
     else Right $ genericFabsOp W32
-  DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $
+
+  DoubleFabsOp -> \args -> opCallishHandledLater args $
     if (ncg && x86ish || ppc) || llvm
     then Left MO_F64_Fabs
     else Right $ genericFabsOp W64
 
-  TagToEnumOp -> panic "emitPrimOp: handled above in cgOpApp"
+  -- tagToEnum# is special: we need to pull the constructor
+  -- out of the table, and perform an appropriate return.
+  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Raw $ \res_ty -> do
+    -- If you're reading this code in the attempt to figure
+    -- out why the compiler panic'ed here, it is probably because
+    -- you used tagToEnum# in a non-monomorphic setting, e.g.,
+    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
+    -- That won't work.
+    let tycon = tyConAppTyCon res_ty
+    MASSERT(isEnumerationTyCon tycon)
+    dflags <- getDynFlags
+    pure [tagToClosure dflags tycon amode]
 
 -- Out of line primops.
 -- TODO compiler need not know about these
@@ -1528,7 +1530,7 @@ dispatchPrimop dflags = \case
   SetThreadAllocationCounter -> alwaysExternal
 
  where
-  alwaysExternal = \_ -> OpDest_External
+  alwaysExternal = \_ -> PrimopCmmEmit_External
   -- Note [QuotRem optimization]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
   --
@@ -1563,57 +1565,55 @@ dispatchPrimop dflags = \case
           ArchPPC_64 _ -> True
           _            -> False
 
--- | Helper datatype used to ensure completion while keeping code smaller. Could
--- be totally eliminated in optimized builds.
-data OpDest
-  = OpDest_Nop
-  | OpDest_Narrow !(Width -> Width -> MachOp, Width)
-  -- | These primops are implemented by CallishMachOps, because they sometimes
-  -- turn into foreign calls depending on the backend.
-  | OpDest_Callish !CallishMachOp
-  | OpDest_Translate !MachOp
-  | OpDest_CallishHandledLater (Either CallishMachOp GenericOp)
-  | OpDest_External
-  -- | Basically a "manual" case, rather than one of the common repetitive forms
-  -- above. The results are a parameter to the returned function so we know the
-  -- choice of variant never depends on them.
-  | OpDest_AllDone ([LocalReg] -- where to put the results
-                    -> FCode ())
-
--- | Wrapper around '@dispatchPrimop@' which implements the cases represented
--- with '@OpDest@'.
---
--- Returns 'Nothing' if this primop should use its out-of-line implementation
--- (defined elsewhere) and 'Just' together with a code generating function that
--- takes the output regs as arguments otherwise.
-emitPrimOp :: DynFlags
-           -> PrimOp            -- the op
-           -> [CmmExpr]         -- arguments
-           -> Maybe ([LocalReg]        -- where to put the results
-                      -> FCode ())
-
--- The rest just translate straightforwardly
-emitPrimOp dflags op args = case dispatchPrimop dflags op args of
-  OpDest_Nop -> Just $ \[res] -> emitAssign (CmmLocal res) arg
-    where [arg] = args
-
-  OpDest_Narrow (mop, rep) -> Just $ \[res] -> emitAssign (CmmLocal res) $
-    CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
-    where [arg] = args
-
-  OpDest_Callish prim -> Just $ \[res] -> emitPrimCall [res] prim args
-
-  OpDest_Translate mop -> Just $ \[res] -> do
-    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)
-    emit stmt
-
-  OpDest_CallishHandledLater callOrNot -> Just $ \res0 -> case callOrNot of
-          Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args
-          Right gen -> gen res0 args
-
-  OpDest_AllDone f -> Just $ f
-
-  OpDest_External -> Nothing
+data PrimopCmmEmit
+  = PrimopCmmEmit_External
+  | PrimopCmmEmit_IntoRegs ([LocalReg] -- where to put the results
+                           -> FCode ())
+  -- | Manual escape hatch, this is just for the '@TagToEnum@'
+  -- primop for now. It would be nice to remove this special case but that is
+  -- future work.
+  | PrimopCmmEmit_Raw (Type -- the return type, some primops are specialized to it
+                       -> FCode [CmmExpr]) -- just for TagToEnum for now
+
+opNop :: [CmmExpr] -> PrimopCmmEmit
+opNop args = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) arg
+  where [arg] = args
+
+opNarrow
+  :: DynFlags
+  -> [CmmExpr]
+  -> (Width -> Width -> MachOp, Width)
+  -> PrimopCmmEmit
+opNarrow dflags args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $
+  CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
+  where [arg] = args
+
+-- | These primops are implemented by CallishMachOps, because they sometimes
+-- turn into foreign calls depending on the backend.
+opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit
+opCallish args prim = PrimopCmmEmit_IntoRegs $ \[res] -> emitPrimCall [res] prim args
+
+opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit
+opTranslate args mop = PrimopCmmEmit_IntoRegs $ \[res] -> do
+  let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)
+  emit stmt
+
+-- | Basically a "manual" case, rather than one of the common repetitive forms
+-- above. The results are a parameter to the returned function so we know the
+-- choice of variant never depends on them.
+opCallishHandledLater
+  :: [CmmExpr]
+  -> Either CallishMachOp GenericOp
+  -> PrimopCmmEmit
+opCallishHandledLater args callOrNot = PrimopCmmEmit_IntoRegs $ \res0 -> case callOrNot of
+  Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args
+  Right gen -> gen res0 args
+
+opAllDone
+  :: ([LocalReg] -- where to put the results
+      -> FCode ())
+  -> PrimopCmmEmit
+opAllDone f = PrimopCmmEmit_IntoRegs $ f
 
 type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
 

compiler/GHC/StgToCmm/Prof.hs

@@ -350,7 +350,7 @@ ldvEnter cl_ptr = do
 
 loadEra :: DynFlags -> CmmExpr
 loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
-    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
+    [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))
              (cInt dflags)]
 
 ldvWord :: DynFlags -> CmmExpr -> CmmExpr

compiler/GHC/StgToCmm/Ticky.hs

@@ -118,7 +118,6 @@ import CmmUtils
 import CLabel
 import SMRep
 
-import Module
 import Name
 import Id
 import BasicTypes
@@ -366,7 +365,7 @@ registerTickyCtr ctr_lbl = do
         , mkStore (CmmLit (cmmLabelOffB ctr_lbl
                                 (oFFSET_StgEntCounter_registeredp dflags)))
                    (mkIntExpr dflags 1) ]
-    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+    ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))
   emit =<< mkCmmIfThen test (catAGraphs register_stmts)
 
 tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
@@ -506,12 +505,12 @@ tickyAllocHeap genuine hp
                      bytes,
             -- Bump the global allocation total ALLOC_HEAP_tot
             addToMemLbl (bWord dflags)
-                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+                        (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot"))
                         bytes,
             -- Bump the global allocation counter ALLOC_HEAP_ctr
             if not genuine then mkNop
             else addToMemLbl (bWord dflags)
-                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+                             (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr"))
                              1
             ]}
 
@@ -575,13 +574,13 @@ ifTickyDynThunk :: FCode () -> FCode ()
 ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
 
 bumpTickyCounter :: FastString -> FCode ()
-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl)
 
 bumpTickyCounterBy :: FastString -> Int -> FCode ()
-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl)
 
 bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)
 
 bumpTickyEntryCount :: CLabel -> FCode ()
 bumpTickyEntryCount lbl = do
@@ -622,7 +621,7 @@ bumpHistogram lbl n = do
     emit (addToMem (bWord dflags)
            (cmmIndexExpr dflags
                 (wordWidth dflags)
-                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+                (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl)))
                 (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))
            1)
 

compiler/GHC/StgToCmm/Utils.hs

@@ -22,6 +22,7 @@ module GHC.StgToCmm.Utils (
         tagToClosure, mkTaggedObjectLoad,
 
         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
+        callerSaveGlobalReg, callerRestoreGlobalReg,
 
         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
         cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
@@ -247,8 +248,8 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
   where
     platform = targetPlatform dflags
 
-    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
-    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
+    caller_save = catAGraphs (map (callerSaveGlobalReg    dflags) regs_to_save)
+    caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save)
 
     system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
                     {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
@@ -256,12 +257,14 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
 
     regs_to_save = filter (callerSaves platform) system_regs
 
-    callerSaveGlobalReg reg
-        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
+callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
+callerSaveGlobalReg dflags reg
+    = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
 
-    callerRestoreGlobalReg reg
-        = mkAssign (CmmGlobal reg)
-                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
+callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
+callerRestoreGlobalReg dflags reg
+    = mkAssign (CmmGlobal reg)
+               (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
 
 
 -------------------------------------------------------------------------

compiler/GHC/ThToHs.hs

@@ -58,27 +58,28 @@ import System.IO.Unsafe
 -------------------------------------------------------------------
 --              The external interface
 
-convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
-convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
+convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
+convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))
   where
     cvt_dec d = wrapMsg "declaration" d (cvtDec d)
 
-convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
-convertToHsExpr loc e
-  = initCvt loc $ wrapMsg "expression" e $ cvtl e
+convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
+convertToHsExpr origin loc e
+  = initCvt origin loc $ wrapMsg "expression" e $ cvtl e
 
-convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
-convertToPat loc p
-  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
+convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
+convertToPat origin loc p
+  = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p
 
-convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
-convertToHsType loc t
-  = initCvt loc $ wrapMsg "type" t $ cvtType t
+convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
+convertToHsType origin loc t
+  = initCvt origin loc $ wrapMsg "type" t $ cvtType t
 
 -------------------------------------------------------------------
-newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
+newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }
     deriving (Functor)
-        -- Push down the source location;
+        -- Push down the Origin (that is configurable by
+        -- -fenable-th-splice-warnings) and source location;
         -- Can fail, with a single error message
 
 -- NB: If the conversion succeeds with (Right x), there should
@@ -91,45 +92,48 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
 -- the spliced-in declarations get a location that at least relates to the splice point
 
 instance Applicative CvtM where
-    pure x = CvtM $ \loc -> Right (loc,x)
+    pure x = CvtM $ \_ loc -> Right (loc,x)
     (<*>) = ap
 
 instance Monad CvtM where
-  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
-                                  Left err -> Left err
-                                  Right (loc',v) -> unCvtM (k v) loc'
+  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
+    Left err -> Left err
+    Right (loc',v) -> unCvtM (k v) origin loc'
 
-initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
-initCvt loc (CvtM m) = fmap snd (m loc)
+initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
+initCvt origin loc (CvtM m) = fmap snd (m origin loc)
 
 force :: a -> CvtM ()
 force a = a `seq` return ()
 
 failWith :: MsgDoc -> CvtM a
-failWith m = CvtM (\_ -> Left m)
+failWith m = CvtM (\_ _ -> Left m)
+
+getOrigin :: CvtM Origin
+getOrigin = CvtM (\origin loc -> Right (loc,origin))
 
 getL :: CvtM SrcSpan
-getL = CvtM (\loc -> Right (loc,loc))
+getL = CvtM (\_ loc -> Right (loc,loc))
 
 setL :: SrcSpan -> CvtM ()
-setL loc = CvtM (\_ -> Right (loc, ()))
+setL loc = CvtM (\_ _ -> Right (loc, ()))
 
 returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
-returnL x = CvtM (\loc -> Right (loc, cL loc x))
+returnL x = CvtM (\_ loc -> Right (loc, cL loc x))
 
 returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
 returnJustL = fmap Just . returnL
 
 wrapParL :: HasSrcSpan a =>
             (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
+wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x)))
 
 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
 -- E.g  wrapMsg "declaration" dec thing
 wrapMsg what item (CvtM m)
-  = CvtM (\loc -> case m loc of
-                     Left err -> Left (err $$ getPprStyle msg)
-                     Right v  -> Right v)
+  = CvtM $ \origin loc -> case m origin loc of
+      Left err -> Left (err $$ getPprStyle msg)
+      Right v  -> Right v
   where
         -- Show the item in pretty syntax normally,
         -- but with all its constructors if you say -dppr-debug
@@ -139,9 +143,9 @@ wrapMsg what item (CvtM m)
                     else text (pprint item))
 
 wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
-wrapL (CvtM m) = CvtM (\loc -> case m loc of
-                               Left err -> Left err
-                               Right (loc',v) -> Right (loc',cL loc v))
+wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
+  Left err -> Left err
+  Right (loc',v) -> Right (loc',cL loc v)
 
 -------------------------------------------------------------------
 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
@@ -152,7 +156,8 @@ cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameL s
         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] }
+        ; th_origin <- getOrigin
+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
 
   | otherwise
   = do  { pat' <- cvtPat pat
@@ -172,7 +177,8 @@ cvtDec (TH.FunD nm cls)
   | otherwise
   = do  { nm' <- vNameL nm
         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' }
+        ; th_origin <- getOrigin
+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
 
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
@@ -403,7 +409,8 @@ cvtDec (TH.PatSynD nm args dir pat)
     cvtDir _ ImplBidir       = return ImplicitBidirectional
     cvtDir n (ExplBidir cls) =
       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
-         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
+         ; th_origin <- getOrigin
+         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms }
 
 cvtDec (TH.PatSynSigD nm ty)
   = do { nm' <- cNameL nm
@@ -464,8 +471,6 @@ cvt_ci_decs doc decs
         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-          --We use FromSource as the origin of the bind
-          -- because the TH declaration is user-written
         ; return (listToBag binds', sigs', fams', ats', adts') }
 
 ----------------
@@ -901,12 +906,14 @@ cvtl e = wrapL (cvt e)
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; let pats = map (parenthesizePat appPrec) ps'
-                            ; return $ HsLam noExtField (mkMatchGroup FromSource
+                            ; th_origin <- getOrigin
+                            ; return $ HsLam noExtField (mkMatchGroup th_origin
                                              [mkSimpleMatch LambdaExpr
                                              pats e'])}
     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; th_origin <- getOrigin
                             ; return $ HsLamCase noExtField
-                                                   (mkMatchGroup FromSource ms')
+                                                   (mkMatchGroup th_origin ms')
                             }
     cvt (TupE es)        = cvt_tup es Boxed
     cvt (UnboxedTupE es) = cvt_tup es Unboxed
@@ -923,8 +930,9 @@ cvtl e = wrapL (cvt e)
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
                             ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}
     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; th_origin <- getOrigin
                             ; return $ HsCase noExtField e'
-                                                 (mkMatchGroup FromSource ms') }
+                                                 (mkMatchGroup th_origin ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (MDoE ss)      = cvtHsDo MDoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss

compiler/backpack/DriverBkp.hs

@@ -54,7 +54,7 @@ import Util
 import qualified GHC.LanguageExtensions as LangExt
 
 import Panic
-import Data.List
+import Data.List ( partition )
 import System.Exit
 import Control.Monad
 import System.FilePath