286827be · db78ac6f · 114b014f · 002594b7 · 3ecc03df · c16f3297
--- a/.circleci/config.yml
+++ b/.circleci/config.yml
-# Questions about this file?
-# See https://gitlab.haskell.org/ghc/ghc/wikis/continuous-integration/usage.
-version: 2
-aliases:
-  - &defaults
-    working_directory: ~/ghc
-  - &prepare
-    run:
-      name: prepare-system
-      command: .circleci/prepare-system.sh
-  - &submodules
-    run:
-      name: submodules
-      command: .circleci/fetch-submodules.sh
-  - &buildenv
-    # ideally we would simply set THREADS here instead of re-detecting it every
-    # time we need it below. Unfortunately, there is no way to set an environment
-    # variable with the result of a shell script.
-    SKIP_PERF_TESTS: NO
-    VERBOSE: 2
-  - &boot
-    run:
-      name: Boot
-      command: |
-        ./boot
-  - &set_git_identity
-      run:
-        name: Set Git Identity
-        command: |
-          git config user.email "ghc-circleci@haskell.org"
-          git config user.name "GHC CircleCI"
-  - &configure_unix
-    run:
-      name: Configure
-      command: ./configure 
-  - &configure_unix_32
-    run:
-      name: Configure
-      command: |
-        setarch i386 ./configure --with-ghc=/opt/ghc-i386/8.4.2/bin/ghc
-  - &configure_bsd
-    run:
-      name: Configure
-      command: ./configure --target=x86_64-unknown-freebsd10
-  - &configure_unreg
-    run:
-      name: Configure
-      command: ./configure --enable-unregisterised
-  - &make
-    run:
-      name: Build
-      command: "make -j`mk/detect-cpu-count.sh` V=0"
-  - &build_hadrian
-    run:
-      name: Build GHC using Hadrian
-      command: |
-        cabal update
-        hadrian/build.sh -j`mk/detect-cpu-count.sh`
-  - &test
-    run:
-      name: Test
-      command: |
-        mkdir -p test-results
-        METRICS_FILE=$(mktemp)
-        echo "export METRICS_FILE=$METRICS_FILE" >> $BASH_ENV
-        make test THREADS=`mk/detect-cpu-count.sh` SKIP_PERF_TESTS=$SKIP_PERF_TESTS TEST_ENV=$TEST_ENV JUNIT_FILE=../../test-results/junit.xml METRICS_FILE=$METRICS_FILE
-  - &store_test_results
-    store_test_results:
-      path: test-results
-  - &push_perf_note
-    run:
-      name: Push Performance Git Notes
-      command: .circleci/push-test-metrics.sh
-  - &store_test_artifacts
-    store_artifacts:
-      # we might want to add the whole output of the test phase
-      # too at some point
-      path: test-results/junit.xml
-  - &slowtest
-    run:
-      name: Full Test
-      command: |
-        mkdir -p test-results
-        make slowtest SKIP_PERF_TESTS=YES THREADS=`mk/detect-cpu-count.sh` JUNIT_FILE=../../test-results/junit.xml
-  - &bindist
-    run:
-      name: Create bindist
-      # Reduce compression effort to 3
-      command: make binary-dist TAR_COMP_OPTS="-2" && mv ghc*.tar.xz ghc.tar.xz
-      # Building bindist takes ~15 minutes without output, account for
-      # that.
-      no_output_timeout: "30m"
-  - &store_bindist
-    store_artifacts:
-      path: ghc.tar.xz
-  - &only_release_tags
-    tags:
-      only: /^ghc-.*/
-  - &ignore_gitlab_branches
-    branches:
-      ignore: /^gitlab\/.*/
-jobs:
-  "validate-x86_64-freebsd":
-    docker:
-      - image: ghcci/x86_64-freebsd
-    environment:
-      TARGET: FreeBSD
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: x86_64-freebsd
-      TEST_ENV: x86_64-freebsd
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_bsd
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-x86_64-darwin":
-    macos:
-      xcode: "9.0"
-    environment:
-      # Disable sphinx PDF output as MacTeX apparently doesn't provide xelatex
-      BUILD_SPHINX_PDF: "NO"
-      MACOSX_DEPLOYMENT_TARGET: "10.7"
-      # Only Sierra and onwards supports clock_gettime. See #12858
-      ac_cv_func_clock_gettime: "no"
-      GHC_COLLECTOR_FLAVOR: x86_64-darwin
-      <<: *buildenv
-      TEST_ENV: x86_64-darwin
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-x86_64-linux-deb8":
-    docker:
-      - image: ghcci/x86_64-linux-deb8:0.1
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: x86_64-linux
-      TEST_ENV: x86_64-linux-deb8
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-x86_64-linux-deb9-integer-simple":
-    docker:
-      - image: ghcci/x86_64-linux-deb9:0.2
-    environment:
-      <<: *buildenv
-      INTEGER_LIBRARY: integer-simple
-      GHC_COLLECTOR_FLAVOR: x86_64-linux-deb9
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-x86_64-linux-deb9":
-    docker:
-      - image: ghcci/x86_64-linux-deb9:0.1
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: x86_64-linux-deb9
-      TEST_ENV: x86_64-linux-deb9
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-hadrian-x86_64-linux-deb8":
-    docker:
-      - image: ghcci/x86_64-linux-deb8:0.1
-    environment:
-      <<: *buildenv
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *build_hadrian
-  "validate-x86_64-linux-deb8-unreg":
-    docker:
-      - image: ghcci/x86_64-linux-deb8:0.1
-    environment:
-      <<: *buildenv
-      TEST_ENV: x86_64-linux-deb8-unreg
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unreg
-      - *make
-      - *test
-      - *store_test_results
-      - *push_perf_note
-      - *store_test_artifacts
-  "validate-x86_64-linux-deb9-llvm":
-    docker:
-      - image: ghcci/x86_64-linux-deb9:0.2
-    environment:
-      <<: *buildenv
-      BUILD_FLAVOUR: perf-llvm
-      TEST_ENV: x86_64-linux-deb9-llvm
-    steps:
-      - run:
-          name: Verify that llc works
-          command: llc
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  # Nightly build with -DDEBUG using devel2 flavour
-  "validate-x86_64-linux-deb8-debug":
-    docker:
-      - image: ghcci/x86_64-linux-deb8:0.1
-    environment:
-      BUILD_FLAVOUR: devel2
-      <<: *buildenv
-      TEST_ENV: x86_64-linux-deb8-debug
-      SKIP_PERF_TESTS: YES
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-i386-linux-deb9":
-    docker:
-      - image: ghcci/i386-linux-deb9:0.2
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: i386-linux-deb9
-      TEST_ENV: i386-linux-deb9
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix_32
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-i386-linux-deb8":
-    docker:
-      - image: ghcci/i386-linux-deb8:0.1
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: i386-linux
-      TEST_ENV: i386-linux-deb8
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix_32
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-x86_64-linux-centos7":
-    docker:
-      - image: ghcci/x86_64-linux-centos7:0.1
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: x86_64-centos7
-      LANG: en_US.UTF-8
-      TEST_ENV: x86_64-centos7
-      # Sphinx is too old
-      BUILD_SPHINX_PDF: NO
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "validate-x86_64-linux-fedora27":
-    docker:
-      - image: ghcci/x86_64-linux-fedora27:0.1
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: x86_64-fedora
-      TEST_ENV: x86_64-linux-fedora27
-    steps:
-      - checkout
-      - *set_git_identity
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *bindist
-      - *store_bindist
-      - *test
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-  "slow-validate-x86_64-linux-deb8":
-    docker:
-      - image: ghcci/x86_64-linux-deb8:0.1
-    environment:
-      <<: *buildenv
-      GHC_COLLECTOR_FLAVOR: x86_64-linux-deb8
-    steps:
-      - checkout
-      - *prepare
-      - *submodules
-      - *boot
-      - *configure_unix
-      - *make
-      - *slowtest
-      - *store_test_results
-      - *store_test_artifacts
-      - *push_perf_note
-workflows:
-  version: 2
-  validate:
-    jobs:
-    - validate-x86_64-linux-deb8:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-    # FreeBSD disabled: https://github.com/haskell/unix/issues/102
-    # - validate-x86_64-freebsd
-    - validate-x86_64-darwin:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-    - validate-x86_64-linux-deb8-llvm:
-        filters:
-          <<: *ignore_gitlab_branches
-    - validate-i386-linux-deb8:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-    - validate-x86_64-linux-deb9:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-    - validate-i386-linux-deb9:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-    - validate-x86_64-linux-centos7:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-    - validate-hadrian-x86_64-linux-deb8:
-        filters:
-          <<: *ignore_gitlab_branches
-    - validate-x86_64-linux-fedora27:
-        filters:
-          <<: [*only_release_tags, *ignore_gitlab_branches]
-  nightly:
-    triggers:
-      - schedule:
-          cron: "0 0 * * *"
-          filters:
-            branches:
-              only:
-                - master
-    jobs:
-    - validate-x86_64-linux-deb8-unreg
-    - validate-x86_64-linux-deb8-llvm
-    - validate-x86_64-linux-deb8-debug
-    - validate-x86_64-linux-deb9
-    - validate-x86_64-linux-deb9-integer-simple
-    - slow-validate-x86_64-linux-deb8
-notify:
-  webhooks:
-    - url: https://phabricator.haskell.org/harbormaster/hook/circleci/
--- a/.circleci/fetch-submodules.sh
+++ b/.circleci/fetch-submodules.sh
-#!/usr/bin/env bash
-set -euo pipefail
-# Use github.com/ghc for those submodule repositories we couldn't connect to.
-git config remote.origin.url git://github.com/ghc/ghc.git
-git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/
-git submodule init # Don't be quiet, we want to show these urls.
-git submodule --quiet update --recursive # Now we can be quiet again.
--- a/.circleci/push-test-metrics.sh
+++ b/.circleci/push-test-metrics.sh
-#!/usr/bin/env bash
-# vim: sw=2 et
-set -euo pipefail
-fail() {
-  echo "ERROR: $*" >&2
-  exit 1
-}
-if [ "$CIRCLE_REPOSITORY_URL" != "git@github.com:ghc/ghc.git" ]; then
-  exit 0
-fi
-GHC_ORIGIN=git@git.haskell.org:ghc
-# Add git.haskell.org as a known host.
-echo "|1|F3mPVCE55+KfApNIMYQ3Dv39sGE=|1bRkvJEJhAN2R0LE/lAjFCEJGl0= ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBBUZS9jGBkE5UzpSo6irnIgcQcfzvbuIOsFc8+N61FwtZncRntbaKPuUimOFPgeaUZLl6Iajz6IIs7aduU0/v+I=" >> ~/.ssh/known_hosts
-echo "|1|2VUMjYSRVpT2qJPA0rA9ap9xILY=|5OThkI4ED9V0J+Es7D5FOD55Klk= ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC+3TLluLAO4lkW60W+N2DFkS+WoRFGqLwHzgd1ifxG9TIm31wChPY3E/hgMnJmgGqWCF4UDUemmyCycEaL7FtKfzjTAclg9EfpQnozyE3T5hIo2WL7SN5O8ttG/bYGuDnn14jLnWwJyN4oz/znWFiDG9e2Oc9YFNlQ+PK8ae5xR4gqBB7EOoj9J1EiPqG2OXRr5Mei3TLsRDU6fnz/e4oFJpKWWeN6M63oePv0qoaGjxcrATZUWsuWrxVMmYo9kP1xRuFJbAUw2m4uVP+793SW1zxySi1HBMtJG+gCDdZZSwYbkV1hassLWBHv1qPttncfX8Zek3Z3VolaTmfWJTo9" >> ~/.ssh/known_hosts
-# Check that a git notes dont already exist.
-# This is a percausion as we reset refs/notes/perf and we want to avoid data loss.
-if [ $(git notes --ref=perf list | wc -l) -ne 0 ]
-then
-  fail "Found an existing git note on HEAD. Expected no git note."
-fi
-# Assert that the METRICS_FILE exists and can be read.
-if [ "$METRICS_FILE" = "" ] || ! [ -r $METRICS_FILE ]
-then
-  fail "Metrics file not found: $METRICS_FILE"
-fi
-# 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 {
-  git fetch -f $GHC_ORIGIN refs/notes/perf:refs/notes/perf || true
-  echo "git notes --ref=perf append -F $METRICS_FILE HEAD"
-  git notes --ref=perf append -F $METRICS_FILE HEAD
-  git push $GHC_ORIGIN refs/notes/perf
-}
-# 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
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -2,12 +2,15 @@ variables:
  GIT_SSL_NO_VERIFY: "1"
  # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: ac65f31dcffb09cd7ca7aaa70f447fcbb19f427f
+  DOCKER_REV: 88e952f165f48cfb956ac9a2486a9263aa4f777c
  # Sequential version number capturing the versions of all tools fetched by
  # .gitlab/win32-init.sh.
  WINDOWS_TOOLCHAIN_VERSION: 1
+  # Disable shallow clones; they break our linting rules
+  GIT_DEPTH: 0
 before_script:
  - python3 .gitlab/fix-submodules.py
  - git submodule sync --recursive
@@ -49,13 +52,12 @@ stages:
 ############################################################
 ghc-linters:
-  allow_failure: true
  stage: lint
  image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
  script:
    - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME
    - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
-    - "echo Merge base $base"
+    - "echo Linting changes between $base..$CI_COMMIT_SHA"
    #    - validate-commit-msg .git $(git rev-list $base..$CI_COMMIT_SHA)
    - validate-whitespace .git $(git rev-list $base..$CI_COMMIT_SHA)
    - .gitlab/linters/check-makefiles.py $base $CI_COMMIT_SHA
@@ -75,18 +77,15 @@ ghc-linters:
  stage: lint
  image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
  script:
+    - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME
+    - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
+    - "echo Linting submodule changes between $base..$CI_COMMIT_SHA"
+    - git submodule foreach git remote update
    - submodchecker .git $(git rev-list $base..$CI_COMMIT_SHA)
  dependencies: []
  tags:
    - lint
-lint-submods:
-  extends: .lint-submods
-  only:
-    refs:
-      - master
-      - /ghc-[0-9]+\.[0-9]+/
 lint-submods-marge:
  extends: .lint-submods
  only:
@@ -97,10 +96,26 @@ lint-submods-marge:
 lint-submods-mr:
  extends: .lint-submods
+  # Allow failure since any necessary submodule patches may not be upstreamed
+  # yet.
  allow_failure: true
  only:
    refs:
      - merge_requests
+  except:
+    variables:
+      - $CI_MERGE_REQUEST_LABELS =~ /.*wip/marge_bot_batch_merge_job.*/
+lint-submods-branch:
+  extends: .lint-submods
+  script:
+    - "echo Linting submodule changes between $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA"
+    - git submodule foreach git remote update
+    - submodchecker .git $(git rev-list $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA)
+  only:
+    refs:
+      - master
+      - /ghc-[0-9]+\.[0-9]+/
 .lint-changelogs:
  stage: lint
@@ -117,6 +132,7 @@ lint-submods-mr:
 lint-changelogs:
  extends: .lint-changelogs
+  # Allow failure since this isn't a final release.
  allow_failure: true
  only:
    refs:
@@ -135,11 +151,10 @@ lint-release-changelogs:
 .validate-hadrian:
  <<: *only-default
-  allow_failure: true
  script:
    - cabal update
    - git clean -xdf && git submodule foreach git clean -xdf
-    - bash .circleci/prepare-system.sh
+    - .gitlab/prepare-system.sh
    - if [[ -d ./cabal-cache ]]; then cp -R ./.cabal-cache ~/.cabal-cache; fi
    - ./boot
    - ./configure $CONFIGURE_ARGS
@@ -158,10 +173,10 @@ lint-release-changelogs:
      - ghc.tar.xz
      - junit.xml
-validate-x86_64-linux-deb8-hadrian:
+validate-x86_64-linux-deb9-hadrian:
  extends: .validate-hadrian
  stage: build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb8:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
  before_script:
    # workaround for docker permissions
    - sudo chown ghc:ghc -R .
@@ -176,7 +191,7 @@ validate-x86_64-linux-deb8-hadrian:
 hadrian-ghc-in-ghci:
  <<: *only-default
  stage: build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb8:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
  before_script:
    # workaround for docker permissions
    - sudo chown ghc:ghc -R .
@@ -190,7 +205,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
-    - bash .circleci/prepare-system.sh
+    - .gitlab/prepare-system.sh
    - if [[ -d ./cabal-cache ]]; then cp -R ./.cabal-cache ~/.cabal-cache; fi
    - ./boot
    - ./configure $CONFIGURE_ARGS
@@ -217,6 +232,8 @@ hadrian-ghc-in-ghci:
    - |
      THREADS=`mk/detect-cpu-count.sh`
      make V=0 -j$THREADS WERROR=-Werror
+    - |
+      make bindisttest
    - |
      make binary-dist TAR_COMP_OPTS="-1"
    - |
@@ -278,6 +295,47 @@ validate-x86_64-darwin:
      - cabal-cache
      - toolchain
+# Disabled because of OS X CI capacity
+.validate-x86_64-darwin-hadrian:
+  <<: *only-default
+  stage: full-build
+  tags:
+    - x86_64-darwin
+  variables:
+    GHC_VERSION: 8.6.3
+    MACOSX_DEPLOYMENT_TARGET: "10.7"
+    ac_cv_func_clock_gettime: "no"
+    LANG: "en_US.UTF-8"
+    CONFIGURE_ARGS: --with-intree-gmp
+    TEST_ENV: "x86_64-darwin"
+  before_script:
+    - git clean -xdf && git submodule foreach git clean -xdf
+    - python3 .gitlab/fix-submodules.py
+    - 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 -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
+    - hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test --summary-junit=./junit.xml
+    - mv _build/bindist/ghc*.tar.xz ghc.tar.xz
+  after_script:
+    - cp -Rf $HOME/.cabal cabal-cache
+  artifacts:
+    when: always
+    expire_in: 2 week
+    reports:
+      junit: junit.xml
+    paths:
+      - ghc.tar.xz
+      - junit.xml
 .validate-linux:
  extends: .validate
  tags:
@@ -295,7 +353,7 @@ validate-x86_64-darwin:
        echo "EXTRA_HADDOCK_OPTS += --hyperlinked-source --quickjump" >> mk/build.mk
      fi
-    - bash .circleci/prepare-system.sh
+    - .gitlab/prepare-system.sh
    # workaround for docker permissions
    - sudo chown ghc:ghc -R .
  after_script:
@@ -318,6 +376,8 @@ validate-x86_64-darwin:
  variables:
    TEST_ENV: "aarch64-linux-deb9"
    BIN_DIST_PREP_TAR_COMP: "bindistprep/ghc-aarch64-linux-deb9.tar.xz"
+    # Inexplicably makeindex fails
+    BUILD_SPHINX_PDF: "NO"
  cache:
    key: linux-aarch64-deb9
  tags:
@@ -384,7 +444,8 @@ nightly-i386-linux-deb9:
  cache:
    key: linux-x86_64-deb9
-validate-x86_64-linux-deb9:
+# Disabled to reduce CI load
+.validate-x86_64-linux-deb9:
  extends: .build-x86_64-linux-deb9
  artifacts:
    when: always
@@ -406,15 +467,30 @@ validate-x86_64-linux-deb9-debug:
  stage: build
  variables:
    BUILD_FLAVOUR: validate
+    TEST_TYPE: slowtest
    TEST_ENV: "x86_64-linux-deb9-debug"
+  artifacts:
+    when: always
+    expire_in: 2 week
-validate-x86_64-linux-deb9-llvm:
+# Disabled to alleviate CI load
+.validate-x86_64-linux-deb9-llvm:
  extends: .build-x86_64-linux-deb9
  stage: full-build
  variables:
    BUILD_FLAVOUR: perf-llvm
    TEST_ENV: "x86_64-linux-deb9-llvm"
+nightly-x86_64-linux-deb9-llvm:
+  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
@@ -610,6 +686,7 @@ nightly-i386-windows-hadrian:
    - 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 bindisttest"
    - bash -c "PATH=`pwd`/toolchain/bin:$PATH make binary-dist TAR_COMP_OPTS=-1"
    - bash -c 'make V=0 test THREADS=`mk/detect-cpu-count.sh` JUNIT_FILE=../../junit.xml'
  tags:
@@ -718,7 +795,7 @@ doc-tarball:
    - x86_64-linux
  image: ghcci/x86_64-linux-deb9:0.2
  dependencies:
-    - validate-x86_64-linux-deb9
+    - validate-x86_64-linux-deb9-debug
    - validate-x86_64-windows
  variables:
    LINUX_BINDIST: "ghc-x86_64-deb9-linux.tar.xz"
@@ -820,6 +897,12 @@ pages:
    - tar -xf haddock.html.tar.xz -C public/doc
    - tar -xf libraries.html.tar.xz -C public/doc
    - tar -xf users_guide.html.tar.xz -C public/doc
+    - |
+      cat >public/index.html <<EOF
+      <!DOCTYPE HTML>
+      <meta charset="UTF-8">
+      <meta http-equiv="refresh" content="1; url=doc/">
+      EOF
    - cp -f index.html public/doc
  only:
    - master

--- a/.gitlab/linters/check-makefiles.py
+++ b/.gitlab/linters/check-makefiles.py
@@ -12,7 +12,8 @@ from linter import run_linters, RegexpLinter
 linters = [
    RegexpLinter(r'--interactive',
-                 message = "Warning: Use `$(TEST_HC_OPTS_INTERACTIVE)` instead of `--interactive -ignore-dot-ghci -v0`.")
+                 message = "Warning: Use `$(TEST_HC_OPTS_INTERACTIVE)` instead of `--interactive -ignore-dot-ghci -v0`.",
+                 path_filter = lambda path: path == 'Makefile')
 ]
 if __name__ == '__main__':

--- a/.gitlab/linters/linter.py
+++ b/.gitlab/linters/linter.py
@@ -73,13 +73,14 @@ class RegexpLinter(LineLinter):
    A :class:`RegexpLinter` produces the given warning message for
    all lines matching the given regular expression.
    """
-    def __init__(self, regex, message):
+    def __init__(self, regex, message, path_filter=lambda path: True):
        LineLinter.__init__(self)
        self.re = re.compile(regex)
        self.message = message
+        self.path_filter = path_filter
    def lint_line(self, path, line_no, line):
-        if self.re.search(line):
+        if self.path_filter(path) and self.re.search(line):
            w = Warning(path=path, line_no=line_no, line_content=line[:-1],
                        message=self.message)
            self.add_warning(w)

--- a/.circleci/prepare-system.sh
+++ b/.circleci/prepare-system.sh
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -866,7 +866,7 @@ case $TargetPlatform in
      esac ;;
    i386-unknown-mingw32) fptools_cv_leading_underscore=yes;;
    x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;;
-    *) AC_RUN_IFELSE([AC_LANG_SOURCE([[#ifdef HAVE_NLIST_H
+    *) AC_RUN_IFELSE([AC_LANG_SOURCE([[#if defined(HAVE_NLIST_H)
 #include <nlist.h>
 struct nlist xYzzY1[] = {{"xYzzY1", 0},{0}};
 struct nlist xYzzY2[] = {{"_xYzzY2", 0},{0}};
@@ -876,7 +876,7 @@ int main(argc, argv)
 int argc;
 char **argv;
 {
-#ifdef HAVE_NLIST_H
+#if defined(HAVE_NLIST_H)
    if(nlist(argv[0], xYzzY1) == 0 && xYzzY1[0].n_value != 0)
        exit(1);
    if(nlist(argv[0], xYzzY2) == 0 && xYzzY2[0].n_value != 0)
@@ -1650,16 +1650,16 @@ then
    [fptools_cv_timer_create_works],
    [AC_TRY_RUN([
 #include <stdio.h>
-#ifdef HAVE_STDLIB_H
+#if defined(HAVE_STDLIB_H)
 #include <stdlib.h>
 #endif
-#ifdef HAVE_TIME_H
+#if defined(HAVE_TIME_H)
 #include <time.h>
 #endif
-#ifdef HAVE_SIGNAL_H
+#if defined(HAVE_SIGNAL_H)
 #include <signal.h>
 #endif
-#ifdef HAVE_UNISTD_H
+#if defined(HAVE_UNISTD_H)
 #include <unistd.h>
 #endif

--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -298,6 +298,24 @@ so the data constructor for T:C had a single argument, namely the
 predicate (C a).  But now we treat that as an ordinary argument, not
 part of the theta-type, so all is well.
+Note [Newtype workers]
+~~~~~~~~~~~~~~~~~~~~~~
+A newtype does not really have a worker. Instead, newtype constructors
+just unfold into a cast. But we need *something* for, say, MkAge to refer
+to. So, we do this:
+* The Id used as the newtype worker will have a compulsory unfolding to
+  a cast. See Note [Compulsory newtype unfolding]
+* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId,
+  as those have special treatment in the back end.
+* There is no top-level binding, because the compulsory unfolding
+  means that it will be inlined (to a cast) at every call site.
+We probably should have a NewtypeWorkId, but these Ids disappear as soon as
+we desugar anyway, so it seems a step too far.
 Note [Compulsory newtype unfolding]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Newtype wrappers, just like workers, have compulsory unfoldings.
@@ -447,6 +465,8 @@ mkDataConWorkId :: Name -> DataCon -> Id
 mkDataConWorkId wkr_name data_con
  | isNewTyCon tycon
  = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info
+      -- See Note [Newtype workers]
  | otherwise
  = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info

--- a/compiler/basicTypes/NameEnv.hs
+++ b/compiler/basicTypes/NameEnv.hs
@@ -25,6 +25,7 @@ module NameEnv (
        emptyDNameEnv,
        lookupDNameEnv,
+        delFromDNameEnv,
        mapDNameEnv,
        alterDNameEnv,
        -- ** Dependency analysis
@@ -147,6 +148,9 @@ emptyDNameEnv = emptyUDFM
 lookupDNameEnv :: DNameEnv a -> Name -> Maybe a
 lookupDNameEnv = lookupUDFM
+delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a
+delFromDNameEnv = delFromUDFM
 mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b
 mapDNameEnv = mapUDFM

--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -4,6 +4,7 @@
 -}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE PatternSynonyms #-}
 #if !defined(GHC_LOADED_INTO_GHCI)
@@ -148,20 +149,18 @@ pattern UniqResult x y = (# x, y #)
 #else
 data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply
+  deriving (Functor)
 #endif
 -- | A monad which just gives the ability to obtain 'Unique's
 newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
+    deriving (Functor)
 instance Monad UniqSM where
  (>>=) = thenUs
  (>>)  = (*>)
-instance Functor UniqSM where
-    fmap f (USM x) = USM (\us0 -> case x us0 of
-                                 UniqResult r us1 -> UniqResult (f r) us1)
 instance Applicative UniqSM where
    pure = returnUs
    (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of

--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -5,6 +5,7 @@
 -- CmmLint: checking the correctness of Cmm statements and expressions
 --
 -----------------------------------------------------------------------------
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GADTs #-}
 module CmmLint (
    cmmLint, cmmLintGraph
@@ -24,7 +25,7 @@ import PprCmm ()
 import Outputable
 import DynFlags
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
 -- Things to check:
 --     - invariant on CmmBlock in CmmExpr (see comment there)
@@ -212,9 +213,7 @@ checkCond _ expr
 -- just a basic error monad:
 newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
+    deriving (Functor)
-instance Functor CmmLint where
-      fmap = liftM
 instance Applicative CmmLint where
      pure a = CmmLint (\_ -> Right a)

--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -556,7 +556,9 @@ data CallishMachOp
  | MO_F64_Acosh
  | MO_F64_Atanh
  | MO_F64_Log
+  | MO_F64_Log1P
  | MO_F64_Exp
+  | MO_F64_ExpM1
  | MO_F64_Fabs
  | MO_F64_Sqrt
  | MO_F32_Pwr
@@ -573,7 +575,9 @@ data CallishMachOp
  | MO_F32_Acosh
  | MO_F32_Atanh
  | MO_F32_Log
+  | MO_F32_Log1P
  | MO_F32_Exp
+  | MO_F32_ExpM1
  | MO_F32_Fabs
  | MO_F32_Sqrt

--- a/compiler/cmm/Hoopl/Block.hs
+++ b/compiler/cmm/Hoopl/Block.hs
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
 module Hoopl.Block
    ( C
    , O
@@ -64,14 +66,8 @@ data MaybeC ex t where
  JustC    :: t -> MaybeC C t
  NothingC ::      MaybeC O t
+deriving instance Functor (MaybeO ex)
-instance Functor (MaybeO ex) where
+deriving instance Functor (MaybeC ex)
-  fmap _ NothingO = NothingO
-  fmap f (JustO a) = JustO (f a)
-instance Functor (MaybeC ex) where
-  fmap _ NothingC = NothingC
-  fmap f (JustC a) = JustC (f a)
 -- -----------------------------------------------------------------------------
 -- The Block type

--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -335,8 +335,8 @@ copyIn dflags conv area formals extra_stk
          local = CmmLocal reg
          width = cmmRegWidth dflags local
          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
-        in CmmAssign local expr 
+        in CmmAssign local expr
      | otherwise =
         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
         where ty = localRegType reg

--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}
 -----------------------------------------------------------------------------
 --
@@ -61,7 +61,7 @@ import Data.Map (Map)
 import Data.Word
 import System.IO
 import qualified Data.Map as Map
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
 import qualified Data.Array.Unsafe as U ( castSTUArray )
 import Data.Array.ST
@@ -788,7 +788,9 @@ pprCallishMachOp_for_C mop
        MO_F64_Acosh    -> text "acosh"
        MO_F64_Atan     -> text "atan"
        MO_F64_Log      -> text "log"
+        MO_F64_Log1P    -> text "log1p"
        MO_F64_Exp      -> text "exp"
+        MO_F64_ExpM1    -> text "expm1"
        MO_F64_Sqrt     -> text "sqrt"
        MO_F64_Fabs     -> text "fabs"
        MO_F32_Pwr      -> text "powf"
@@ -805,7 +807,9 @@ pprCallishMachOp_for_C mop
        MO_F32_Acosh    -> text "acoshf"
        MO_F32_Atanh    -> text "atanhf"
        MO_F32_Log      -> text "logf"
+        MO_F32_Log1P    -> text "log1pf"
        MO_F32_Exp      -> text "expf"
+        MO_F32_ExpM1    -> text "expm1f"
        MO_F32_Sqrt     -> text "sqrtf"
        MO_F32_Fabs     -> text "fabsf"
        MO_WriteBarrier -> text "write_barrier"
@@ -1078,10 +1082,7 @@ pprExternDecl lbl
        <> semi
 type TEState = (UniqSet LocalReg, Map CLabel ())
-newtype TE a = TE { unTE :: TEState -> (a, TEState) }
+newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)
-instance Functor TE where
-      fmap = liftM
 instance Applicative TE where
      pure a = TE $ \s -> (a, s)

--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -577,7 +577,7 @@ isSimpleScrut _                _           = return False
 isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
 -- True iff the op cannot block or allocate
-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _ _) _ = return $! not (playSafe safe)
 -- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
 isSimpleOp (StgPrimOp DataToTagOp) _ = return False
 isSimpleOp (StgPrimOp op) stg_args                  = do

--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
+{-# LANGUAGE DeriveFunctor #-}
 -- | Our extended FCode monad.
 -- We add a mapping from names to CmmExpr, to support local variable names in
@@ -53,7 +54,7 @@ import UniqFM
 import Unique
 import UniqSupply
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
 -- | The environment contains variable definitions or blockids.
 data Named
@@ -73,6 +74,7 @@ type Decls      = [(FastString,Named)]
 --      and a list of local declarations. Returns the resulting list of declarations.
 newtype CmmParse a
        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
+    deriving (Functor)
 type ExtCode = CmmParse ()
@@ -82,9 +84,6 @@ returnExtFC a   = EC $ \_ _ s -> return (s, a)
 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
 thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
-instance Functor CmmParse where
-      fmap = liftM
 instance Applicative CmmParse where
      pure = returnExtFC
      (<*>) = ap

--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -34,7 +34,6 @@ import CmmUtils
 import MkGraph
 import Type
 import RepType
-import TysPrim
 import CLabel
 import SMRep
 import ForeignCall
@@ -44,20 +43,26 @@ import Outputable
 import UniqSupply
 import BasicTypes
+import TyCoRep
+import TysPrim
+import Util (zipEqual)
 import Control.Monad
 -----------------------------------------------------------------------------
 -- Code generation for Foreign Calls
 -----------------------------------------------------------------------------
-- | emit code for a foreign call, and return the results to the sequel.
+-- | Emit code for a foreign call, and return the results to the sequel.
--
+-- Precondition: the length of the arguments list is the same as the
+-- arity of the foreign function.
 cgForeignCall :: ForeignCall            -- the op
+              -> Type                   -- type of foreign function
              -> [StgArg]               -- x,y    arguments
              -> Type                   -- result type
              -> FCode ReturnKind
-cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
+cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
  = do  { dflags <- getDynFlags
        ; let -- in the stdcall calling convention, the symbol needs @size appended
              -- to it, where size is the total number of bytes of arguments.  We
@@ -70,7 +75,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
              -- ToDo: this might not be correct for 64-bit API
            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
                                     (wORD_SIZE dflags)
-        ; cmm_args <- getFCallArgs stg_args
+        ; cmm_args <- getFCallArgs stg_args typ
        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
        ; let ((call_args, arg_hints), cmm_target)
                = case target of
@@ -492,43 +497,128 @@ stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
 closureField :: DynFlags -> ByteOff -> ByteOff
 closureField dflags off = off + fixedHdrSize dflags
-- -----------------------------------------------------------------------------
+-- Note [Unlifted boxed arguments to foreign calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
 -- For certain types passed to foreign calls, we adjust the actual
-- value passed to the call.  For ByteArray#/Array# we pass the
+-- value passed to the call.  For ByteArray#, Array#, SmallArray#,
-- address of the actual array, not the address of the heap object.
+-- and ArrayArray#, we pass the address of the array's payload, not
+-- the address of the heap object. For example, consider
-getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
+--   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()
+-- At a Haskell call like `foo x y`, we'll generate a C call that
+-- is more like
+--   c_foo( x+8, y )
+-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves
+-- it past the header words of the ByteArray object to point directly
+-- to the data inside the ByteArray#. (The exact offset depends
+-- on the target architecture and on profiling) By contrast, (y :: Int#)
+-- requires no such adjustment.
+--
+-- This adjustment is performed by 'add_shim'. The size of the
+-- adjustment depends on the type of heap object. But
+-- how can we determine that type? There are two available options.
+-- We could use the types of the actual values that the foreign call
+-- has been applied to, or we could use the types present in the
+-- foreign function's type. Prior to GHC 8.10, we used the former
+-- strategy since it's a little more simple. However, in issue #16650
+-- and more compellingly in the comments of
+-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was
+-- demonstrated that this leads to bad behavior in the presence
+-- of unsafeCoerce#. Returning to the above example, suppose the
+-- Haskell call looked like
+--   foo (unsafeCoerce# p)
+-- where the types of expressions comprising the arguments are
+--   p :: (Any :: TYPE 'UnliftedRep)
+--   i :: Int#
+-- so that the unsafe-coerce is between Any and ByteArray#.
+-- These two types have the same kind (they are both represented by
+-- a heap pointer) so no GC errors will occur if we do this unsafe coerce.
+-- By the time this gets to the code generator the cast has been
+-- discarded so we have
+--   foo p y
+-- But we *must* adjust the pointer to p by a ByteArray# shim,
+-- *not* by an Any shim (the Any shim involves no offset at all).
+--
+-- To avoid this bad behavior, we adopt the second strategy: use
+-- the types present in the foreign function's type.
+-- In collectStgFArgTypes, we convert the foreign function's
+-- type to a list of StgFArgType. Then, in add_shim, we interpret
+-- these as numeric offsets.
+getFCallArgs ::
+     [StgArg]
+  -> Type -- the type of the foreign function
+  -> FCode [(CmmExpr, ForeignHint)]
 -- (a) Drop void args
 -- (b) Add foreign-call shim code
 -- It's (b) that makes this differ from getNonVoidArgAmodes
+-- Precondition: args and typs have the same length
-getFCallArgs args
+-- See Note [Unlifted boxed arguments to foreign calls]
-  = do  { mb_cmms <- mapM get args
+getFCallArgs args typ
+  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))
        ; return (catMaybes mb_cmms) }
  where
-    get arg | null arg_reps
+    get (arg,typ)
-            = return Nothing
+      | null arg_reps
-            | otherwise
+      = return Nothing
-            = do { cmm <- getArgAmode (NonVoid arg)
+      | otherwise
-                 ; dflags <- getDynFlags
+      = do { cmm <- getArgAmode (NonVoid arg)
-                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
+           ; dflags <- getDynFlags
-            where
+           ; return (Just (add_shim dflags typ cmm, hint)) }
-              arg_ty   = stgArgType arg
+      where
-              arg_reps = typePrimRep arg_ty
+        arg_ty   = stgArgType arg
-              hint     = typeForeignHint arg_ty
+        arg_reps = typePrimRep arg_ty
+        hint     = typeForeignHint arg_ty
-add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
-add_shim dflags arg_ty expr
+-- The minimum amount of information needed to determine
-  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+-- the offset to apply to an argument to a foreign call.
-  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
+-- See Note [Unlifted boxed arguments to foreign calls]
+data StgFArgType
-  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
+  = StgPlainType
-  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
+  | StgArrayType
+  | StgSmallArrayType
-  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+  | StgByteArrayType
-  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
+-- See Note [Unlifted boxed arguments to foreign calls]
-  | otherwise = expr
+add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
+add_shim dflags ty expr = case ty of
+  StgPlainType -> expr
+  StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
+  StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
+  StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)
+-- From a function, extract information needed to determine
+-- the offset of each argument when used as a C FFI argument.
+-- See Note [Unlifted boxed arguments to foreign calls]
+collectStgFArgTypes :: Type -> [StgFArgType]
+collectStgFArgTypes = go []
+  where
+    -- Skip foralls
+    go bs (ForAllTy _ res) = go bs res
+    go bs (AppTy{}) = reverse bs
+    go bs (TyConApp{}) = reverse bs
+    go bs (LitTy{}) = reverse bs
+    go bs (TyVarTy{}) = reverse bs
+    go  _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"
+    go  _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"
+    go bs (FunTy {ft_arg = arg, ft_res=res}) =
+      go (typeToStgFArgType arg:bs) res
+-- Choose the offset based on the type. For anything other
+-- than an unlifted boxed type, there is no offset.
+-- See Note [Unlifted boxed arguments to foreign calls]
+typeToStgFArgType :: Type -> StgFArgType
+typeToStgFArgType typ
+  | tycon == arrayPrimTyCon = StgArrayType
+  | tycon == mutableArrayPrimTyCon = StgArrayType
+  | tycon == arrayArrayPrimTyCon = StgArrayType
+  | tycon == mutableArrayArrayPrimTyCon = StgArrayType
+  | tycon == smallArrayPrimTyCon = StgSmallArrayType
+  | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType
+  | tycon == byteArrayPrimTyCon = StgByteArrayType
+  | tycon == mutableByteArrayPrimTyCon = StgByteArrayType
+  | otherwise = StgPlainType
  where
-    tycon           = tyConAppTyCon (unwrapType arg_ty)
+  -- should be a tycon app, since this is a foreign call
-        -- should be a tycon app, since this is a foreign call
+  tycon = tyConAppTyCon (unwrapType typ)
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GADTs #-}
 -----------------------------------------------------------------------------
@@ -111,9 +112,7 @@ import Data.List
 --------------------------------------------------------
 newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
+    deriving (Functor)
-instance Functor FCode where
-    fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')
 instance Applicative FCode where
    pure val = FCode (\_info_down state -> (val, state))