diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2018-10-23 14:20:13 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-10-23 14:20:13 -0400 |
| commit | 94756201349685a34c4495addd3484fdfcc8b498 (patch) | |
| tree | fd4a9cee20d3c2b79f56ded7e02fb0c01b26b6c9 /hadrian | |
| parent | 575b35f4cdc18045bccd42d341d6f25d95c0696c (diff) | |
| parent | 45f3bff7016a2a0cd9a5455a882ced984655e90b (diff) | |
| download | haskell-94756201349685a34c4495addd3484fdfcc8b498.tar.gz | |
Add 'hadrian/' from commit '45f3bff7016a2a0cd9a5455a882ced984655e90b'
git-subtree-dir: hadrian
git-subtree-mainline: 575b35f4cdc18045bccd42d341d6f25d95c0696c
git-subtree-split: 45f3bff7016a2a0cd9a5455a882ced984655e90b
Diffstat (limited to 'hadrian')
110 files changed, 10131 insertions, 0 deletions
diff --git a/hadrian/.ghci b/hadrian/.ghci new file mode 100644 index 0000000000..8bb287b0c9 --- /dev/null +++ b/hadrian/.ghci @@ -0,0 +1,11 @@ +:set -Wall -fno-warn-name-shadowing -isrc -i../libraries/Cabal/Cabal +:set -XDeriveFunctor +:set -XDeriveGeneric +:set -XFlexibleInstances +:set -XGeneralizedNewtypeDeriving +:set -XLambdaCase +:set -XRecordWildCards +:set -XScopedTypeVariables +:set -XTupleSections + +:load Main diff --git a/hadrian/.gitignore b/hadrian/.gitignore new file mode 100644 index 0000000000..697afc9663 --- /dev/null +++ b/hadrian/.gitignore @@ -0,0 +1,26 @@ +# generated by the configure script +cfg/system.config + +# build.bat and build.sh specific +/bin/ + +# build.cabal.sh specific +/dist/ +/.cabal-sandbox/ +cabal.sandbox.config + +# build.cabal-new.sh specific +/dist-newstyle/ +.ghc.environment.* + +# build.stack.sh and build.stack.bat specific +/.stack-work/ + +# the user settings +/UserSettings.hs + +# Mostly temp file by emacs +*~ + +# ghcid output +/ghcid.txt
\ No newline at end of file diff --git a/hadrian/.travis.yml b/hadrian/.travis.yml new file mode 100644 index 0000000000..f670784cb5 --- /dev/null +++ b/hadrian/.travis.yml @@ -0,0 +1,110 @@ +sudo: true +matrix: + include: + - os: linux + env: MODE="selftest" + compiler: "GHC 8.4.3" + addons: + apt: + packages: + - ghc-8.4.3 + - cabal-install-2.4 + - zlib1g-dev + sources: hvr-ghc + + before_install: + - PATH="/opt/ghc/8.4.3/bin:$PATH" + - PATH="/opt/cabal/2.4/bin:$PATH" + + script: + # Run internal Hadrian tests, after boot and configure. + - hadrian/build.sh -c selftest + + - os: linux + env: MODE="--flavour=quickest" + compiler: "GHC 8.4.3" + addons: + apt: + packages: + - ghc-8.4.3 + - cabal-install-2.4 + - zlib1g-dev + sources: hvr-ghc + + before_install: + - PATH="/opt/ghc/8.4.3/bin:$PATH" + - PATH="/opt/cabal/2.4/bin:$PATH" + + script: + # Build GHC, letting hadrian boot & configure the ghc source tree + - hadrian/build.sh -c -j $MODE --no-progress --progress-colour=never --profile=- + + - os: linux + env: MODE="--flavour=quickest --integer-simple" + compiler: "GHC 8.6.1" + addons: + apt: + packages: + - ghc-8.6.1 + - cabal-install-2.4 + - zlib1g-dev + sources: hvr-ghc + + before_install: + - PATH="/opt/ghc/8.6.1/bin:$PATH" + - PATH="/opt/cabal/2.4/bin:$PATH" + + script: + # boot, configure and build GHC + - hadrian/build.sh -c -j $MODE --no-progress --progress-colour=never --profile=- + + # Test GHC binary + - _build/stage1/bin/ghc -e 1+2 + + - os: osx + osx_image: xcode8 + env: MODE="--flavour=quickest --integer-simple" + before_install: + - brew update + - brew install ghc cabal-install + - brew upgrade python + + script: + # Due to timeout limit of OS X build on Travis CI, + # we will ignore selftest + - hadrian/build.sh -j -c $MODE --no-progress --progress-colour=never --profile=- + + # Test GHC binary + - _build/stage1/bin/ghc -e 1+2 + +install: + # Add Cabal to PATH + - PATH="$HOME/.cabal/bin:$PATH" + - export PATH + - env + + # Fetch GHC sources into ./ghc + - git --version + - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ + - git clone --depth 1 --recursive git://github.com/ghc/ghc + # --shallow-submodules is not supported on travis standard git 1.8 (linux), but it is supported + # on Travis Mac OS X machines. But it does not work with github mirrors because it cannot + # find commits. + + # Install all Hadrian and GHC build dependencies + - cabal update + - cabal install alex happy + + # GHC comes with an older version of Hadrian, so we delete it + - rm -rf ghc/hadrian/.git + + # Travis has already cloned Hadrian into ./ and we need to move it + # to ./ghc/hadrian -- one way to do it is to move the .git directory + # and perform a hard reset in order to regenerate Hadrian files + - mv .git ghc/hadrian + - cd ghc/hadrian && git reset --hard HEAD && cd .. + +cache: + directories: + - $HOME/.cabal + - $HOME/.ghc diff --git a/hadrian/LICENSE b/hadrian/LICENSE new file mode 100644 index 0000000000..ff60fa8b44 --- /dev/null +++ b/hadrian/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2014-2017 Andrey Mokhov + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/hadrian/README.md b/hadrian/README.md new file mode 100644 index 0000000000..b88d08dd47 --- /dev/null +++ b/hadrian/README.md @@ -0,0 +1,224 @@ +Hadrian +======= + +[](https://travis-ci.org/snowleopard/hadrian) [](https://ci.appveyor.com/project/snowleopard/hadrian) [](https://circleci.com/gh/snowleopard/hadrian) + +Hadrian is a new build system for the [Glasgow Haskell Compiler][ghc]. It is based +on [Shake][shake] and we hope that it will soon replace the current +[Make-based build system][make]. If you are curious about the rationale behind the +project and the architecture of the build system you can find more details in +this [Haskell Symposium 2016 paper](https://dl.acm.org/authorize?N41275) and this +[Haskell eXchange 2016 talk][talk]. + +The new build system can work side-by-side with the existing build system, since it +places all build artefacts in a dedicated directory (called `_build` by default). +See [this guide](https://ghc.haskell.org/trac/ghc/wiki/Building/Hadrian/QuickStart) +if you'd like to start using Hadrian for building GHC. + +Your first build +---------------- + +Beware, the build system is in the alpha development phase. Things are shaky and sometimes +break; there are numerous [known issues][issues]. Not afraid? Then put on the helmet and +run the following command from root of the GHC tree: + +``` +hadrian/build.sh -j +``` + +or on Windows: + +``` +hadrian/build.bat -j +``` + +Here flag `-j` enables parallelism and is optional. We will further refer to the build script +simply as `build`. Note that Hadrian can also run the `boot` and `configure` scripts +automatically if you pass the flag `--configure`, or simply `-c`. See the overview of +command line flags below. + +Notes: + +* If the default build script doesn't work, you might want to give a try to another one, e.g. based +on Cabal sandboxes (`build.cabal.*`), Stack (`build.stack.*`) or the global package database +(`build.global-db.*`). Also see [instructions for building GHC on Windows using Stack][windows-build]. + +* Hadrian is written in Haskell and depends on `shake` (plus a few packages that `shake` depends on), +`mtl`, `quickcheck`, and GHC core libraries. + +* If you have never built GHC before, start with the [preparation guide][ghc-preparation]. + +Using the build system +---------------------- +Once your first build is successful, simply run `build` to rebuild. Build results +are placed into `_build` and `inplace` directories. + +#### Command line flags + +In addition to standard Shake flags (try `--help`), the build system +currently supports several others: + +* `--build-root=PATH` or `-oPATH`: specify the directory in which you want to store all +build products. By default Hadrian builds everything in the `_build/` subdirectory of +the GHC source tree. Unlike the Make build system, Hadrian doesn't have any "inplace" +logic left anymore. This option is therefore useful for GHC developers who want to build +GHC in different ways or at different commits, from the same source directory, and have +the build products sit in different, isolated folders. + +* `--configure` or `-c`: use this flag to run the `boot` and `configure` scripts +automatically, so that you don't have to remember to run them manually as you normally +do when using Make (typically only in the first build): + ```bash + ./boot + ./configure # On Windows run ./configure --enable-tarballs-autodownload + ``` + Beware that with this flag Hadrian may do network I/O on Windows to download necessary + tarballs, which may sometimes be undesirable. + +* `--flavour=FLAVOUR`: choose a build flavour. The following settings are currently supported: +`default`, `quick`, `quickest`, `perf`, `prof`, `devel1` and `devel2`. As an example, the +`quickest` flavour adds `-O0` flag to all GHC invocations and builds libraries only in the +`vanilla` way, which speeds up builds by 3-4x. Build flavours are documented +[here](https://github.com/snowleopard/hadrian/blob/master/doc/flavours.md). + +* `--freeze1`: freeze Stage1 GHC, i.e. do not rebuild it even if some of its source files +are out-of-date. This allows to significantly reduce the rebuild time when you are working +on a feature that affects both Stage1 and Stage2 compilers, but may lead to incorrect +build results. To unfreeze Stage1 GHC simply drop the `--freeze1` flag and Hadrian will +rebuild all out-of-date files. + +* `--integer-simple`: build GHC using the `integer-simple` integer library (instead +of `integer-gmp`). + +* `--progress-colour=MODE`: choose whether to use colours when printing build progress +info. There are three settings: `never` (do not use colours), `auto` (attempt to detect +whether the console supports colours; this is the default setting), and `always` (use +colours). + +* `--progress-info=STYLE`: choose how build progress info is printed. There are four +settings: `none`, `brief` (one line per build command; this is the default setting), +`normal` (typically a box per build command), and `unicorn` (when `normal` just won't do). + +* `--split-objects`: generate split objects, which are switched off by default. Due to +a GHC [bug][ghc-split-objs-bug], you need a full clean rebuild when using this flag. + +* `--verbose`: run Hadrian in verbose mode. In particular this prints diagnostic messages +by Shake oracles. + +#### User settings + +The Make-based build system uses `mk/build.mk` to specify user build settings. We +use `hadrian/UserSettings.hs` for the same purpose, see [documentation](doc/user-settings.md). + +#### Clean and full rebuild + +* `build clean` removes all build artefacts. + +* `build -B` forces Shake to rerun all rules, even if the previous build results are +are still up-to-date. + +#### Documentation + +To build GHC documentation, run `build docs`. Note that finer-grain documentation +targets (e.g. building only HTML documentation or only the GHC User's Guide) +are currently not supported. + +#### Source distribution + +To build a GHC source distribution tarball, run `build source-dist`. + +#### Binary distribution + +To build a GHC binary distribution, run `build binary-dist`. The resulting +tarball contains just enough to support the + +``` sh +$ ./configure [--prefix=PATH] && make install +``` + +workflow, for now. + +#### Testing + +* `build validate` runs GHC tests by simply executing `make fast` in `testsuite/tests` +directory. This can be used instead of `sh validate --fast --no-clean` in the existing +build system. Note: this will rebuild Stage2 GHC, `ghc-pkg` and `hpc` if they are out of date. + +* `build test` runs GHC tests by calling the `testsuite/driver/runtests.py` python +script with appropriate flags. The current implementation is limited and cannot +replace the `validate` script (see [#187][validation-issue]). + +* `build selftest` runs tests of the build system. Current test coverage is close to +zero (see [#197][test-issue]). + +Troubleshooting +--------------- + +Here are a few simple suggestions that might help you fix the build: + +* The Hadrian submodule in GHC is occasionally behind the master branch of this repository, + which contains most recent bug fixes. To switch to the most recent version of Hadrian, + run `git pull https://github.com/snowleopard/hadrian.git`. Beware: the most recent version + contains the most recent bugs too! If this works, please raise an issue and we will try to + push the changes to the GHC submodule as soon as possible. + +* Hadrian is occasionally broken by changes in GHC. If this happens, you might want to switch + to an earlier GHC commit. + +* If Hadrian fails with the message `Configuration file hadrian/cfg/system.config is missing`, + you have probably forgotten to pass the `--configure` flag during the first build. + +* If you need help in debugging Hadrian, read the [wiki](https://github.com/snowleopard/hadrian/wiki) + and Shake's [debugging tutorial](https://shakebuild.com/debugging). + +If everything fails, don't hesitate to [raise an issue](https://github.com/snowleopard/hadrian/issues/new). + +Current limitations +------------------- +The new build system still lacks many important features: +* Validation is not implemented: [#187][validation-issue]. +* Dynamic linking on Windows is not supported [#343][dynamic-windows-issue]. +* There is no support for binary distribution: [#219][bin-dist-issue]. + +Check out [milestones] to see when we hope to resolve the above limitations. + +How to contribute +----------------- + +The best way to contribute is to try the new build system, report the issues +you found, and attempt to fix them. Please note: the codebase is very unstable +at present and we expect a lot of further refactoring. If you would like to +work on a particular issue, please let everyone know by adding a comment about +this. The issues that are currently on the critical path and therefore require +particular attention are listed in [#239](https://github.com/snowleopard/hadrian/issues/239). +Also have a look at [projects](https://github.com/snowleopard/hadrian/projects) +where open issues and pull requests are grouped into categories. + +Acknowledgements +---------------- + +I started this project as part of my 6-month research visit to Microsoft +Research Cambridge, which was funded by Newcastle University, EPSRC, and +Microsoft Research. I would like to thank Simon Peyton Jones, Neil Mitchell +and Simon Marlow for kick-starting the project and for their guidance. +Zhen Zhang has done fantastic work on Hadrian as part of his Summer of +Haskell 2017 [project](https://summer.haskell.org/ideas.html#hadrian-ghc), +solving a few heavy and long-overdue issues. Last but not least, big thanks +to all other project [contributors][contributors], who helped me endure and +enjoy the project. + +[ghc]: https://en.wikipedia.org/wiki/Glasgow_Haskell_Compiler +[shake]: https://github.com/ndmitchell/shake +[make]: https://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +[talk]: https://skillsmatter.com/skillscasts/8722-meet-hadrian-a-new-build-system-for-ghc +[issues]: https://github.com/snowleopard/hadrian/issues +[ghc-preparation]: https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation +[ghc-windows-quick-build]: https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Windows#AQuickBuild +[windows-build]: https://github.com/snowleopard/hadrian/blob/master/doc/windows.md +[ghc-split-objs-bug]: https://ghc.haskell.org/trac/ghc/ticket/11315 +[test-issue]: https://github.com/snowleopard/hadrian/issues/197 +[validation-issue]: https://github.com/snowleopard/hadrian/issues/187 +[dynamic-windows-issue]: https://github.com/snowleopard/hadrian/issues/343 +[bin-dist-issue]: https://github.com/snowleopard/hadrian/issues/219 +[milestones]: https://github.com/snowleopard/hadrian/milestones +[contributors]: https://github.com/snowleopard/hadrian/graphs/contributors diff --git a/hadrian/appveyor.yml b/hadrian/appveyor.yml new file mode 100644 index 0000000000..1a18abe975 --- /dev/null +++ b/hadrian/appveyor.yml @@ -0,0 +1,38 @@ +clone_folder: "c:\\new-hadrian" +environment: + global: + STACK_ROOT: "c:\\sr" + +cache: + - "c:\\sr -> appveyor.yml" + +install: + # Get Stack + - curl -ostack.zip -LsS --insecure https://www.stackage.org/stack/windows-x86_64 + - 7z x stack.zip stack.exe + + # Note: AppVeyor has already cloned Hadrian into c:\new-hadrian + # Fetch GHC sources into c:\ghc + - cd .. + - git clone --recursive git://git.haskell.org/ghc.git + # GHC comes with an older version of Hadrian, so we delete it + - rm -rf ghc\hadrian + # Copy new Hadrian into ./ghc/hadrian + - cp -r new-hadrian ghc\hadrian + + # Install Alex and Happy + - set PATH=C:\Users\appveyor\AppData\Roaming\local\bin;%PATH% + - ghc\hadrian\stack install --install-ghc alex happy > nul + + # Install all Hadrian and GHC build dependencies + - cd ghc\hadrian + - stack setup > nul + - appveyor-retry stack exec -- pacman -S autoconf automake-wrapper make patch python3 tar --noconfirm + +build_script: + # Build GHC + - cd .. + - hadrian\build -c -j --flavour=quickest --integer-simple --no-progress --progress-colour=never --profile=- + + # Test GHC binary + - _build\stage1\bin\ghc -e 1+2 diff --git a/hadrian/build.bat b/hadrian/build.bat new file mode 100644 index 0000000000..01a869f4f7 --- /dev/null +++ b/hadrian/build.bat @@ -0,0 +1,6 @@ +@echo off +setlocal +cd %~dp0 + +rem By default on Windows we build Hadrian using Stack +./build.stack.bat %* diff --git a/hadrian/build.cabal.bat b/hadrian/build.cabal.bat new file mode 100644 index 0000000000..b47c0bfe88 --- /dev/null +++ b/hadrian/build.cabal.bat @@ -0,0 +1,41 @@ +@echo off +set CABAL=cabal +set CABFLAGS=--disable-documentation --disable-profiling + +rem It is currently more robust to pass Cabal an absolute path to the project file. +set PROJ="%CD%/hadrian/cabal.project" + +if not exist %PROJ% ( + echo Current working directory must be GHC's top-level folder + exit /B 2 +) + +"%CABAL%" 2> NUL +if not %ERRORLEVEL% equ 1 ( + echo Please make sure 'cabal' is in your PATH + exit /B 2 +) + +for /F "tokens=*" %%a in ('%CABAL% --numeric-version') do set CABVERSTR=%%a +for /F "delims=. tokens=1,2,3,4" %%a in ("%CABVERSTR%") do ( + set CABMAJOR=%%a + set CABMINOR=%%b + set CABREV=%%c + set CABPATCH=%%d +) + +set "_cabal_ok=0" +if %CABMAJOR% gtr 2 set _cabal_ok=1 +if %CABMAJOR% equ 2 ( + if %CABMINOR% geq 2 set _cabal_ok=1 +) +if %_cabal_ok% equ 1 ( + "%CABAL%" --project-file=%PROJ% new-build %CABFLAGS% -j exe:hadrian + "%CABAL%" --project-file=%PROJ% new-run %CABFLAGS% exe:hadrian -- ^ + --lint ^ + --directory "%CD%" ^ + %* +) else ( + echo Cabal version is too old; you need at least cabal-install 2.2 + exit /B 2 +) diff --git a/hadrian/build.cabal.sh b/hadrian/build.cabal.sh new file mode 100755 index 0000000000..9fddd61c4e --- /dev/null +++ b/hadrian/build.cabal.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash + +CABAL=cabal +CABFLAGS="--disable-documentation --disable-profiling" + +# It is currently more robust to pass Cabal an absolute path to the project file. +PROJ="$PWD/hadrian/cabal.project" + +set -euo pipefail + +if ! [ -f "$PROJ" ]; then + echo "Current working directory must be GHC's top-level folder" + exit 2 +fi + +if ! type "$CABAL" > /dev/null; then + echo "Please make sure 'cabal' is in your PATH" + exit 2 +fi + +CABVERSTR=$("$CABAL" --numeric-version) +CABVER=( ${CABVERSTR//./ } ) + +if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ]; +then + "$CABAL" --project-file="$PROJ" new-build $CABFLAGS -j exe:hadrian + "$CABAL" --project-file="$PROJ" new-run $CABFLAGS exe:hadrian -- \ + --lint \ + --directory "$PWD" \ + "$@" +else + echo "Cabal version is too old; you need at least cabal-install 2.2" + exit 2 +fi diff --git a/hadrian/build.nix.sh b/hadrian/build.nix.sh new file mode 100755 index 0000000000..4b03ea8418 --- /dev/null +++ b/hadrian/build.nix.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env nix-shell +#! nix-shell -i bash shell.nix + +# This script sets up the build environment by invoking nix-shell shell.nix +# and then runs the hadrian executable. + +function rl { + TARGET_FILE="$1" + + cd "$(dirname "$TARGET_FILE")" + TARGET_FILE="$(basename "$TARGET_FILE")" + + # Iterate down a (possible) chain of symlinks + while [ -L "$TARGET_FILE" ] + do + TARGET_FILE="$(readlink "$TARGET_FILE")" + cd "$(dirname "$TARGET_FILE")" + TARGET_FILE="$(basename "$TARGET_FILE")" + done + + # Compute the canonicalized name by finding the physical path + # for the directory we're in and appending the target file. + PHYS_DIR="$(pwd -P)" + RESULT="$PHYS_DIR/$TARGET_FILE" + echo "$RESULT" +} + +absoluteRoot="$(dirname "$(rl "$0")")" +echo $absoluteRoot +cd "$absoluteRoot" + +hadrian \ + --lint \ + --directory="$absoluteRoot/.." \ + "$@" diff --git a/hadrian/build.sh b/hadrian/build.sh new file mode 100755 index 0000000000..1fde2d6373 --- /dev/null +++ b/hadrian/build.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# By default on Linux/MacOS we build Hadrian using Cabal +(. "hadrian/build.cabal.sh" "$@") diff --git a/hadrian/build.stack.bat b/hadrian/build.stack.bat new file mode 100644 index 0000000000..674375a3cf --- /dev/null +++ b/hadrian/build.stack.bat @@ -0,0 +1,11 @@ +@echo off +setlocal +rem Change the current directory to the one containing this script +cd %~dp0 + +rem Build Hadrian and dependencies and exit the script if the build failed +stack build +if %errorlevel% neq 0 exit /B %errorlevel% + +rem Run Hadrian in GHC top directory forwarding additional user arguments +stack exec hadrian -- --lint --directory ".." %* diff --git a/hadrian/build.stack.nix.sh b/hadrian/build.stack.nix.sh new file mode 100755 index 0000000000..59ac061805 --- /dev/null +++ b/hadrian/build.stack.nix.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash + +set -euo pipefail + +# readlink on os x, doesn't support -f, to prevent the +# need of installing coreutils (e.g. through brew, just +# for readlink, we use the follownig substitute. +# +# source: http://stackoverflow.com/a/1116890 +function rl { + TARGET_FILE="$1" + + cd "$(dirname "$TARGET_FILE")" + TARGET_FILE="$(basename "$TARGET_FILE")" + + # Iterate down a (possible) chain of symlinks + while [ -L "$TARGET_FILE" ] + do + TARGET_FILE="$(readlink "$TARGET_FILE")" + cd "$(dirname "$TARGET_FILE")" + TARGET_FILE="$(basename "$TARGET_FILE")" + done + + # Compute the canonicalized name by finding the physical path + # for the directory we're in and appending the target file. + PHYS_DIR="$(pwd -P)" + RESULT="$PHYS_DIR/$TARGET_FILE" + echo "$RESULT" +} + +absoluteRoot="$(dirname "$(rl "$0")")" + +HADRIAN_NIX=YES ${absoluteRoot}/build.stack.sh diff --git a/hadrian/build.stack.sh b/hadrian/build.stack.sh new file mode 100755 index 0000000000..2b1ff1d059 --- /dev/null +++ b/hadrian/build.stack.sh @@ -0,0 +1,39 @@ +#!/usr/bin/env bash + +set -euo pipefail + +# readlink on os x, doesn't support -f, to prevent the +# need of installing coreutils (e.g. through brew, just +# for readlink, we use the follownig substitute. +# +# source: http://stackoverflow.com/a/1116890 +function rl { + TARGET_FILE="$1" + + cd "$(dirname "$TARGET_FILE")" + TARGET_FILE="$(basename "$TARGET_FILE")" + + # Iterate down a (possible) chain of symlinks + while [ -L "$TARGET_FILE" ] + do + TARGET_FILE="$(readlink "$TARGET_FILE")" + cd "$(dirname "$TARGET_FILE")" + TARGET_FILE="$(basename "$TARGET_FILE")" + done + + # Compute the canonicalized name by finding the physical path + # for the directory we're in and appending the target file. + PHYS_DIR="$(pwd -P)" + RESULT="$PHYS_DIR/$TARGET_FILE" + echo "$RESULT" +} + +absoluteRoot="$(dirname "$(rl "$0")")" +cd "$absoluteRoot" + +stack build --no-library-profiling ${HADRIAN_NIX:+--nix} + +stack exec hadrian -- \ + --lint \ + --directory "$absoluteRoot/.." \ + "$@" diff --git a/hadrian/cabal.project b/hadrian/cabal.project new file mode 100644 index 0000000000..176d1eef94 --- /dev/null +++ b/hadrian/cabal.project @@ -0,0 +1,2 @@ +packages: ./ + ../libraries/Cabal/Cabal/ diff --git a/hadrian/cfg/system.config.in b/hadrian/cfg/system.config.in new file mode 100644 index 0000000000..344706d630 --- /dev/null +++ b/hadrian/cfg/system.config.in @@ -0,0 +1,128 @@ +# This file is processed by the configure script. +# See hadrian/src/UserSettings.hs for user-defined settings. +#=========================================================== + +# Paths to builders: +#=================== + +alex = @AlexCmd@ +ar = @ArCmd@ +autoreconf = autoreconf +cc = @CC@ +happy = @HappyCmd@ +hs-cpp = @HaskellCPPCmd@ +ld = @LdCmd@ +make = @MakeCmd@ +nm = @NmCmd@ +objdump = @ObjdumpCmd@ +ranlib = @REAL_RANLIB_CMD@ +sphinx-build = @SPHINXBUILD@ +system-ar = @AR_STAGE0@ +system-cc = @CC_STAGE0@ +system-ghc = @WithGhc@ +system-ghc-pkg = @GhcPkgCmd@ +tar = @TarCmd@ +patch = @PatchCmd@ +perl = @PerlCmd@ +xelatex = @XELATEX@ + +# Python 3 is required to run test driver. +# See: https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk#L220 +python = python3 + +# Information about builders: +#============================ + +ar-supports-at-file = @ArSupportsAtFile@ +cc-clang-backend = @CC_CLANG_BACKEND@ +cc-llvm-backend = @CC_LLVM_BACKEND@ +gcc-is-clang = @GccIsClang@ +hs-cpp-args = @HaskellCPPArgs@ + +# Build options: +#=============== + +solaris-broken-shld = @SOLARIS_BROKEN_SHLD@ +split-objects-broken = @SplitObjsBroken@ +ghc-unregisterised = @Unregisterised@ +ghc-source-path = @hardtop@ +leading-underscore = @LeadingUnderscore@ + +# Information about build, host and target systems: +#================================================== + +build-platform = @BuildPlatform@ +build-arch = @BuildArch_CPP@ +build-os = @BuildOS_CPP@ +build-vendor = @BuildVendor_CPP@ + +host-platform = @HostPlatform@ +host-arch = @HostArch_CPP@ +host-os = @HostOS_CPP@ +host-vendor = @HostVendor_CPP@ + +target-platform = @TargetPlatform@ +target-platform-full = @TargetPlatformFull@ +target-arch = @TargetArch_CPP@ +target-os = @TargetOS_CPP@ +target-vendor = @TargetVendor_CPP@ +llvm-target = @LLVMTarget_CPP@ + +cross-compiling = @CrossCompiling@ + +dynamic-extension = @soext_target@ + +ghc-version = @GhcVersion@ +ghc-major-version = @GhcMajVersion@ +ghc-minor-version = @GhcMinVersion@ +ghc-patch-level = @GhcPatchLevel@ + +supports-this-unit-id = @SUPPORTS_THIS_UNIT_ID@ + +project-name = @ProjectName@ +project-version = @ProjectVersion@ +project-version-int = @ProjectVersionInt@ +project-patch-level = @ProjectPatchLevel@ +project-patch-level1 = @ProjectPatchLevel1@ +project-patch-level2 = @ProjectPatchLevel2@ +project-git-commit-id = @ProjectGitCommitId@ + +# Compilation and linking flags: +#=============================== + +conf-cc-args-stage0 = @CONF_CC_OPTS_STAGE0@ +conf-cc-args-stage1 = @CONF_CC_OPTS_STAGE1@ +conf-cc-args-stage2 = @CONF_CC_OPTS_STAGE2@ + +conf-cpp-args-stage0 = @CONF_CPP_OPTS_STAGE0@ +conf-cpp-args-stage1 = @CONF_CPP_OPTS_STAGE1@ +conf-cpp-args-stage2 = @CONF_CPP_OPTS_STAGE2@ + +conf-gcc-linker-args-stage0 = @CONF_GCC_LINKER_OPTS_STAGE0@ +conf-gcc-linker-args-stage1 = @CONF_GCC_LINKER_OPTS_STAGE1@ +conf-gcc-linker-args-stage2 = @CONF_GCC_LINKER_OPTS_STAGE2@ + +conf-ld-linker-args-stage0 = @CONF_LD_LINKER_OPTS_STAGE0@ +conf-ld-linker-args-stage1 = @CONF_LD_LINKER_OPTS_STAGE1@ +conf-ld-linker-args-stage2 = @CONF_LD_LINKER_OPTS_STAGE2@ + +# Include and library directories: +#================================= + +curses-lib-dir = @CURSES_LIB_DIRS@ + +iconv-include-dir = @ICONV_INCLUDE_DIRS@ +iconv-lib-dir = @ICONV_LIB_DIRS@ + +gmp-include-dir = @GMP_INCLUDE_DIRS@ +gmp-lib-dir = @GMP_LIB_DIRS@ + +use-system-ffi = @UseSystemLibFFI@ +ffi-include-dir = @FFIIncludeDir@ +ffi-lib-dir = @FFILibDir@ + +# Optional Dependencies: +#======================= + +with-libdw = @UseLibdw@ +have-lib-mingw-ex = @HaveLibMingwEx@ diff --git a/hadrian/circle.yml b/hadrian/circle.yml new file mode 100644 index 0000000000..4d0d97340e --- /dev/null +++ b/hadrian/circle.yml @@ -0,0 +1,45 @@ +machine: + xcode: + version: 8.0 + environment: + MODE: --flavour=quickest --integer-simple + +dependencies: + override: + - brew update + - brew install ghc cabal-install python3 + - brew link ghc cabal-install python3 + - cabal update + - cabal install alex 'happy >= 1.19.4' mtl shake QuickCheck + cache_directories: + - ~/.cabal + - ~/.ghc + - /usr/local/Cellar + +compile: + override: + # Fetch GHC sources into ./ghc + - git --version + - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ + - git clone --depth 1 --recursive git://github.com/ghc/ghc + + # GHC comes with an older version of Hadrian, so we delete it + - rm -rf ghc/hadrian/.git + # move hadrian's .git into ./ghc/hadrian and perform a hard reset in order to regenerate Hadrian files + - mv .git ghc/hadrian + # NOTE: we must write them in the same line because each line + # in CircleCI is a separate process, thus you can't "cd" for the other lines + - cd ghc/hadrian; git reset --hard HEAD + - cd ghc; ./boot && PATH=~/.cabal/bin:$PATH ./configure + + # XXX: export PATH doesn't work well either, so we use inline env + # Self test + - cd ghc; PATH=~/.cabal/bin:$PATH hadrian/build.sh selftest + + # Build GHC + - cd ghc; PATH=~/.cabal/bin:$PATH hadrian/build.sh -j $MODE --no-progress --progress-colour=never --profile=- + +test: + override: + # Test GHC binary + - ghc/_build/stage1/bin/ghc -e 1+2 diff --git a/hadrian/doc/cross-compile.md b/hadrian/doc/cross-compile.md new file mode 100644 index 0000000000..724d0e17bd --- /dev/null +++ b/hadrian/doc/cross-compile.md @@ -0,0 +1,59 @@ +## Build a cross-compiling GHC + +In this example, our host machine is "Ubuntu 16.04.2 LTS, Linux ubuntu 4.4.0-79-generic 86_64". + +We need to download necessary tools, including: + +- [LLVM-4.0 source](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz), you need to build it yourself. Remember to choose release channel and use gold linker (`cmake -DCMAKE_BUILD_TYPE=Release -DLLVM_USE_LINKER=gold ..`) +- `sudo apt-get install gcc-arm-linux-gnueabihf` to install the GCC cross-compiler +- Download and install [Haskell Platform 8.0.2](https://haskell.org/platform/download/8.0.2/haskell-platform-8.0.2-unknown-posix--full-x86_64.tar.gz). Install it according to [instructions here](https://www.haskell.org/platform/linux.html#linux-generic) + +After all the dependencies are in place: + +- `git clone https://github.com/ghc/ghc` +- `cd ghc` +- `git clone https://github.com/snowleopard/hadrian` +- `git submodule update --init` +- `./configure --target=arm-linux-gnueabihf` +- `cd hadrian` +- Modify `src/UserSettings.hs`, set `stage1Only` to `True`. +- Build the compiler by e.g. `./build.sh --flavour=quickest --integer-simple -V -j` + +After that, you should have built `inplace/bin/ghc-stage1` cross compiler. We will go to the next section to validate this. + +**NOTE**: Use of `-c` to configure the target is currently not supported. Please manually run `./configure` like above. + +## Test run + +Write a simple hello world haskell program: + +```haskell +module Main where +main = putStrLn "Hello, world!" +``` +Compile it with cross-compiling GHC: `<ghc-folder>/inplace/bin/ghc-stage1 -static Main`. Note that we created a static version of it which packs together all depending libraries. + +- Install QEMU: `sudo apt-get install qemu-system-arm` +- Download `vmlinuz` (kernel) and `initrd.gz` (initial ramdisk), e.g. from [this mirror](https://mirrors.tuna.tsinghua.edu.cn/ubuntu-ports/dists/xenial/main/installer-armhf/current/images/generic-lpae/cdrom/). +- Add the ARM Linux executable `Main` to the initial ramdisk so we can load it directly into memory. No need for real installation + + `gunzip initrd.gz` to get `initrd` + + `mkdir tmp2; cd tmp2; sudo cpio -id < ../initrd` to get a file system + + `cp /PATH/TO/Main usr/bin` + + `find . | cpio --create --format='newc' > /tmp/newinitrd` to pack back the `initrd` + + `gzip /tmp/newinitrd` + + Move `newinitrd` to where `vmlinuz` is, rename it to `newinitrd.img` + + Run the following configured QEMU: + +```bash +#!/bin/sh +qemu-system-arm \ + -kernel vmlinuz \ + -initrd newinitrd.img \ + -append "root=/dev/vda2 rootfstype=ext4" \ + -no-reboot \ + -nographic \ + -m 1024 \ + -M virt +``` + +This will lead you to a installer interface. But we don't need to do that, so we can save ourself from the hassle of setting up networks etc. We just keep `Go Back`, until see a line `Execute a shell`, and select it. Now you get a shell, go find `/usr/bin/Main` and run it! diff --git a/hadrian/doc/flavours.md b/hadrian/doc/flavours.md new file mode 100644 index 0000000000..f276dbb265 --- /dev/null +++ b/hadrian/doc/flavours.md @@ -0,0 +1,176 @@ +# Build flavours + +Hadrian supports a few predefined _build flavours_, i.e. collections of build +settings that fully define a GHC build (see `src/Flavour.hs`). Users can add their +own build flavours if need be, as described +[here](https://github.com/snowleopard/hadrian/blob/master/doc/user-settings.md#build-flavour). + +## Arguments + +The following table summarises extra arguments passed to GHC in different build flavours. +There are four groups of arguments: arguments in `hsDefault` are passed to GHC for all Haskell +source files, `hsLibrary` arguments are added when compiling libraries, `hsCompiler` +when compiling the `compiler` library, and `hsGhc` when compiling/linking the GHC program. + +<table> + <tr> + <th rowspan="3">Flavour</th> + <th colspan="8">Extra arguments</th> + </tr> + <tr> + <th colspan="2">hsDefault</td> + <th colspan="2">hsLibrary</td> + <th colspan="2">hsCompiler</td> + <th colspan="2">hsGhc</td> + </tr> + <tr> + <th>stage0</td> + <th>stage1+</td> + <th>stage0</td> + <th>stage1+</td> + <th>stage0</td> + <th>stage1+</td> + <th>stage0</td> + <th>stage1+</td> + </tr> + <tr> + <th>default<br></td> + <td>-O<br>-H64m<br></td> + <td>-O2<br>-H64m</td> + <td></td> + <td></td> + <td></td> + <td></td> + <td></td> + <td></td> + </tr> + <tr> + <th>quick</td> + <td>-O0<br>-H64m</td> + <td>-O0<br>-H64m</td> + <td></td> + <td>-O</td> + <td>-O</td> + <td></td> + <td>-O</td> + <td></td> + </tr> + <tr> + <th>quickest</td> + <td>-O0<br>-H64m</td> + <td>-O0<br>-H64m</td> + <td></td> + <td></td> + <td>-O</td> + <td></td> + <td>-O</td> + <td></td> + </tr> + <tr> + <th>perf</td> + <td>-O<br>-H64m</td> + <td>-O<br>-H64m</td> + <td></td> + <td>-O2</td> + <td>-O</td> + <td>-O2</td> + <td>-O</td> + <td>-O2</td> + </tr> + <tr> + <th>prof</td> + <td>-O0<br>-H64m</td> + <td>-O0<br>-H64m</td> + <td></td> + <td>-O</td> + <td>-O</td> + <td>-O</td> + <td>-O</td> + <td>-O</td> + </tr> + <tr> + <th>devel1</td> + <td>-O<br>-H64m</td> + <td>-O<br>-H64m</td> + <td></td> + <td>-dcore-lint</td> + <td>-O0<br>-DDEBUG</td> + <td></td> + <td>-O0<br>-DDEBUG</td> + <td></td> + </tr> + <tr> + <th>devel2</td> + <td>-O<br>-H64m</td> + <td>-O<br>-H64m</td> + <td></td> + <td>-dcore-lint</td> + <td></td> + <td>-O0<br>-DDEBUG</td> + <td></td> + <td>-O0<br>-DDEBUG</td> + </tr> +</table> + +## Ways + +Libraries and GHC can be built in different _ways_, e.g. with or without profiling +information. The following table lists ways that are built in different flavours. + +<table> + <tr> + <th rowspan="2">Flavour</th> + <th colspan="2">Library ways</th> + <th colspan="2">RTS ways</th> + <th colspan="2">Profiled GHC</th> + </tr> + <tr> + <th>stage0</th> + <th>stage1+</th> + <th>stage0</th> + <th>stage1+</th> + <th>stage0</th> + <th>stage1+</th> + </tr> + <tr> + <th>default<br>perf<br>prof<br>devel1<br>devel2</td> + <td>vanilla</td> + <td>vanilla<br>profiling<br>dynamic</td> + <td>logging<br>debug<br>threaded<br>threadedDebug<br>threadedLogging + <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic + <br>loggingDynamic<br>threadedLoggingDynamic + </td> + <td> + logging<br>debug<br>threaded<br>threadedDebug<br> + threadedLogging<br>threadedProfiling + <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic + <br>loggingDynamic<br>threadedLoggingDynamic + </td> + <td>Only in<br>prof<br>flavour</td> + <td>Only in<br>prof<br>flavour</td> +</tr> +<tr> + <th>quick</th> + <td>vanilla</td> + <td>vanilla<br>dynamic</td> + <td>logging<br>debug<br>threaded<br>threadedDebug<br>threadedLogging + <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic + <br>loggingDynamic<br>threadedLoggingDynamic + </td> + <td>logging<br>debug<br>threaded<br>threadedDebug<br>threadedLogging + <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic + <br>loggingDynamic<br>threadedLoggingDynamic + </td> + <td>No</td> + <td>No</td> +</tr> +<tr> + <th>quickest</th> + <td>vanilla</td> + <td>vanilla</td> + <td>vanilla<br>threaded</td> + <td>vanilla<br>threaded</td> + <td>No</td> + <td>No</td> +</tr> +</table> diff --git a/hadrian/doc/user-settings.md b/hadrian/doc/user-settings.md new file mode 100644 index 0000000000..b81c0dc582 --- /dev/null +++ b/hadrian/doc/user-settings.md @@ -0,0 +1,220 @@ +# User settings + +You can customise Hadrian by copying the file `hadrian/src/UserSettings.hs` to +`hadrian/UserSettings.hs` and overriding the default build settings (if you don't +copy the file your changes will be tracked by `git` and you can accidentally commit +them). Here we document currently supported settings. + +## Build flavour + +Build _flavour_ is a collection of build settings that fully define a GHC build +(see `src/Flavour.hs`): +```haskell +data Flavour = Flavour { + -- | Flavour name, to select this flavour from command line. + name :: String, + -- | Use these command line arguments. + args :: Args, + -- | Build these packages. + packages :: Stage -> Action [Package], + -- | Either 'integerGmp' or 'integerSimple'. + integerLibrary :: Action Package, + -- | Build libraries these ways. + libraryWays :: Ways, + -- | Build RTS these ways. + rtsWays :: Ways, + -- | Build split objects. + splitObjects :: Predicate, + -- | Build dynamic GHC programs. + dynamicGhcPrograms :: Action Bool, + -- | Enable GHCi debugger. + ghciWithDebugger :: Bool, + -- | Build profiled GHC. + ghcProfiled :: Bool, + -- | Build GHC with debug information. + ghcDebugged :: Bool } +``` +Hadrian provides several built-in flavours (`defaultFlavour`, `quickFlavour`, and a few +others; see `hadrian/doc/flavours.md`), which can be activated from the command line, +e.g. by passing `--flavour=quick`. Users can define new build flavours by adding them +to `userFlavours` list: +```haskell +-- | User-defined build flavours. See 'userFlavour' as an example. +userFlavours :: [Flavour] +userFlavours = [userFlavour] -- Add more build flavours if need be. + +-- | This is an example user-defined build flavour. Feel free to modify it and +-- use by passing @--flavour=user@ from the command line. +userFlavour :: Flavour +userFlavour = defaultFlavour { name = "user" } -- Modify other settings here. +``` +Now `--flavour=user` will run Hadrian with `userFlavour` settings. In the +following sections we look at specific fields of the `Flavour` record in +more detail. Note: `defaultFlavour`, as well as its individual fields such +as `defaultArgs`, `defaultPackages`, etc. that we use below, are defined in module +`Settings.Default`. + +## Command line arguments + +One of the key features of Hadrian is that users can easily modify any build command. +The build system will detect the change and will rerun all affected build rules during +the next build, without requiring a full rebuild. + +For example, here is how to pass an extra argument `-O0` to all invocations of +GHC when compiling package `cabal`: +```haskell +userFlavour :: Flavour +userFlavour = defaultFlavour { name = "user", args = defaultArgs <> userArgs } + +userArgs :: Args +userArgs = builder Ghc ? package cabal ? arg "-O0" +``` +Builders such as `Ghc` are defined in `src/Builder.hs`, and all packages that +are currently built as part of the GHC are defined in `src/GHC.hs`. + +You can combine several custom command line settings using `mconcat`: +```haskell +userArgs :: Args +userArgs = mconcat + [ builder Ghc ? package cabal ? arg "-O0" + , package rts ? input "//PrimOps.c" ? pure ["-fno-PIC", "-static"] ] +``` +You can match any combination of the `builder`, `stage`, `package`, `way`, `input` +and `output` predicates when specifying custom command line arguments. File +patterns such as `"//Prelude.*"` can be used when matching input and output files, +where `//` matches an arbitrary number of path components and `*` matches an entire +path component, excluding any separators. + +## Packages + +Users can add and remove packages from particular build stages. As an example, +below we add package `base` to Stage0 and remove package `haskeline` from Stage1: +```haskell +userFlavour :: Flavour +userFlavour = defaultFlavour { name = "user", packages = modifiedPackages } + +modifiedPackages :: Stage -> Action [Package] +modifiedPackages stage = do + packages <- defaultPackages stage + return $ case stage of + Stage0 -> packages ++ [base] + Stage1 -> packages \\ [haskeline] + _ -> packages +``` +If you are working on a new GHC package you need to let Hadrian know about it +by adding it to `userPackages`: +```haskell +userPackages :: [Package] +userPackages = [userPackage] + +-- An example package that lives in "libraries/user-package" directory. +userPackage :: Package +userPackage = library "user-package" +``` +You will also need to add `userPackage` to a specific build stage by modifying +the `packages` setting of the user flavour as otherwise it will not be built. + +You can choose which integer library to use when builing GHC using the +`integerLibrary` setting of the build flavour. Possible values are: `integerGmp` +(default) and `integerSimple`. +```haskell +userFlavour :: Flavour +userFlavour = defaultFlavour { name = "user", integerLibrary = integerSimple } +``` +## Build ways + +Packages can be built in a number of ways, such as `vanilla`, `profiling` (with +profiling information enabled), and many others as defined in `src/Way.hs`. You +can change the default build ways by modifying `libraryWays` and `rtsWays` fields +of the `Flavour` record as required. As an example, below we remove `profiling` +from the list of library ways: +```haskell +noProfilingFlavour :: Flavour +noProfilingFlavour = defaultFlavour + { name = "no-profiling" + , libraryWays = remove [profiling] defaultLibraryWays + , ghcProfiled = False } -- Can't build profiled GHC without profiled libraries +``` +Note that `rtsWays` is computed from `libraryWays` by default, therefore the above +change will lead to the removal of `threadedProfiling` way from `rtsWays`. To +change this behaviour, you can override the default `rtsWays` setting. + +Similarly, if we want to completely turn off dynamic linking, we can define a custom +`Flavour` to this effect: +``` haskell +noDynamicFlavour :: Flavour +noDynamicFlavour = defaultFlavour + { name = "no-dynamic" + , libraryWays = remove [dynamic] defaultLibraryWays } +``` + +## Verbose command lines + +By default Hadrian does not print full command lines during the build process +and instead prints short human readable digests for each executed command. You +can suppress this behaviour completely or partially using `verboseCommand` setting: +```haskell +-- | Set to 'True' to print full command lines during the build process. Note: +-- this is a 'Predicate', hence you can enable verbose output only for certain +-- targets, e.g.: @verboseCommand = package ghcPrim@. +verboseCommand :: Predicate +verboseCommand = do + verbosity <- expr getVerbosity + return $ verbosity >= Loud +``` +For example, to print the full command lines used to compile GHC executables, +set `verboseCommands` to: +```haskell +verboseCommand :: Predicate +verboseCommand = input "ghc/Main.hs" +``` +Below are a few other examples: +```haskell +-- Print command lines for all Ghc Link invocations: +verboseCommand = builder (Ghc Link) + +-- Print command lines when compiling files in package compiler using Gcc: +verboseCommand = builder (Gcc Compile) &&^ package compiler + +-- Use patterns when matching files: +verboseCommand = output "//rts/sm/*" &&^ way threaded + +-- Print all commands: +verboseCommand = return True +``` + +## Miscellaneous + +By setting `stage1Only = True` you can disable building Stage2 GHC and Stage2 +utilities such as `haddock`. Note that all Stage0 and Stage1 libraries will +still be built. + +To change the default behaviour of Hadrian with respect to building split +objects, override the `splitObjects` setting of the `Flavour` record: +```haskell +userFlavour :: Flavour +userFlavour = defaultFlavour { name = "user", splitObjects = return False } +``` + +Hadrian prints various progress info during the build. You can change the colours +used by default by overriding `buildProgressColour` and `successColour`: +```haskell +-- | Set colour for build progress messages (e.g. executing a build command). +buildProgressColour :: BuildProgressColour +buildProgressColour = mkBuildProgressColour (Dull Magenta) + +-- | Set colour for success messages (e.g. a package is built successfully). +successColour :: SuccessColour +successColour = mkSuccessColour (Dull Green) +``` + +Your options are `Dull Colour`, `Vivid Colour`, or `Extended Code`. `Dull` +colours are the ANSI 8-bit colours, `Vivid` correspond to the 16-bit codes that +end with ";1", and `Extended` let's you enter a manual code for the 256 colour +set. E.g. + +``` +Dull Blue +Vivid Cyan +Extended "203" +``` diff --git a/hadrian/doc/windows.md b/hadrian/doc/windows.md new file mode 100644 index 0000000000..0ad2086547 --- /dev/null +++ b/hadrian/doc/windows.md @@ -0,0 +1,70 @@ +# Building GHC on Windows
+
+[](https://ci.appveyor.com/project/snowleopard/hadrian)
+
+Here is how you can build GHC, from source, on Windows. We assume that `git` and `stack` are installed
+(see [prerequisites](https://github.com/snowleopard/hadrian/blob/master/doc/windows.md#prerequisites)).
+
+```sh
+# Get GHC and Hadrian sources; git core.autocrlf should be set to false (see Prerequisites section)
+git clone --recursive git://git.haskell.org/ghc.git
+cd ghc
+git clone git://github.com/snowleopard/hadrian
+
+# Download and install the bootstrapping GHC and MSYS2
+cd hadrian
+stack setup
+
+# Install utilities required during the GHC build process
+stack exec -- pacman -S autoconf automake-wrapper make patch python tar --noconfirm
+
+# Build Hadrian and dependencies (including GHC dependencies Alex and Happy)
+stack build
+
+# Build GHC
+# Note that the --configure flag is required only for the first build
+stack exec hadrian -- --directory ".." -j --flavour=quickest --configure
+
+# Test GHC
+cd ..
+inplace\bin\ghc-stage2 -e 1+2
+```
+
+The entire process should take about 20 minutes. Note, this will build GHC without
+optimisations. If you need an optimised GHC, drop the `--flavour=quickest` flag from
+the build command line (this will slow down the build to about an hour).
+
+These are currently not the
+[official GHC building instructions](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Windows),
+but are much simpler and may also be more robust.
+
+The `stack build` and `stack exec hadrian` commands can be replaced by an invocation
+of Hadrian's Stack-based build script: `build.stack.bat -j --flavour=quickest`. Use this
+script if you plan to work on Hadrian and/or rebuild GHC often.
+
+## Prerequisites
+
+The above works on a clean machine with `git` and `stack` installed (tested with default
+installation settings), which you can get from https://git-scm.com/download/win and
+https://www.stackage.org/stack/windows-x86_64-installer.
+
+Note that `git` should be configured to check out Unix-style line endings. The default behaviour
+of `git` on Windows is to check out Windows-style line endings which can cause issues during the
+build. This can be changed using the following command:
+
+ git config --global core.autocrlf false
+
+If you would like to restore the default behaviour later run:
+
+ git config --global core.autocrlf true
+
+## Testing
+
+These instructions have been tested on a clean Windows 10 machine using the
+[free VirtualBox image](https://dev.windows.com/en-us/microsoft-edge/tools/vms/windows/),
+and are also routinely tested on
+[Hadrian's AppVeyor CI instance](https://ci.appveyor.com/project/snowleopard/hadrian/history).
+
+## Notes
+
+Beware of the [current limitations of Hadrian](https://github.com/snowleopard/hadrian#current-limitations).
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal new file mode 100644 index 0000000000..fec927a834 --- /dev/null +++ b/hadrian/hadrian.cabal @@ -0,0 +1,139 @@ +name: hadrian +version: 0.1.0.0 +synopsis: GHC build system +license: BSD3 +license-file: LICENSE +author: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard +maintainer: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard +copyright: Andrey Mokhov 2014-2017 +category: Development +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/snowleopard/hadrian + +executable hadrian + main-is: Main.hs + hs-source-dirs: . + , src + other-modules: Base + , Builder + , CommandLine + , Context + , Context.Path + , Context.Type + , Environment + , Expression + , Expression.Type + , Flavour + , Hadrian.Builder + , Hadrian.Builder.Ar + , Hadrian.Builder.Sphinx + , Hadrian.Builder.Tar + , Hadrian.Expression + , Hadrian.Haskell.Cabal + , Hadrian.Haskell.Cabal.Type + , Hadrian.Haskell.Cabal.Parse + , Hadrian.Oracles.ArgsHash + , Hadrian.Oracles.Cabal + , Hadrian.Oracles.Cabal.Rules + , Hadrian.Oracles.Cabal.Type + , Hadrian.Oracles.DirectoryContents + , Hadrian.Oracles.Path + , Hadrian.Oracles.TextFile + , Hadrian.Package + , Hadrian.Target + , Hadrian.Utilities + , Oracles.Flag + , Oracles.Setting + , Oracles.ModuleFiles + , Oracles.TestSettings + , Packages + , Rules + , Rules.BinaryDist + , Rules.Clean + , Rules.Compile + , Rules.Configure + , Rules.Dependencies + , Rules.Documentation + , Rules.Generate + , Rules.Gmp + , Rules.Libffi + , Rules.Library + , Rules.Nofib + , Rules.Program + , Rules.Register + , Rules.Selftest + , Rules.SourceDist + , Rules.Test + , Settings + , Settings.Builders.Alex + , Settings.Builders.Cabal + , Settings.Builders.Common + , Settings.Builders.Cc + , Settings.Builders.Configure + , Settings.Builders.DeriveConstants + , Settings.Builders.GenPrimopCode + , Settings.Builders.Ghc + , Settings.Builders.GhcPkg + , Settings.Builders.Haddock + , Settings.Builders.Happy + , Settings.Builders.Hsc2Hs + , Settings.Builders.HsCpp + , Settings.Builders.Ld + , Settings.Builders.Make + , Settings.Builders.RunTest + , Settings.Builders.Xelatex + , Settings.Default + , Settings.Flavours.Common + , Settings.Flavours.Development + , Settings.Flavours.Performance + , Settings.Flavours.Profiled + , Settings.Flavours.Quick + , Settings.Flavours.QuickCross + , Settings.Flavours.Quickest + , Settings.Packages + , Settings.Warnings + , Stage + , Target + , UserSettings + , Utilities + , Way + , Way.Type + default-language: Haskell2010 + default-extensions: DeriveFunctor + , DeriveGeneric + , FlexibleInstances + , GeneralizedNewtypeDeriving + , LambdaCase + , RecordWildCards + , ScopedTypeVariables + , TupleSections + other-extensions: MultiParamTypeClasses + , TypeFamilies + build-depends: base >= 4.8 && < 5 + , Cabal >= 2.4 && < 2.5 + , containers == 0.5.* + , directory >= 1.2 && < 1.4 + , extra >= 1.4.7 + , mtl == 2.2.* + , parsec >= 3.1 && < 3.2 + , QuickCheck >= 2.6 && < 2.12 + , shake >= 0.16.4 + , transformers >= 0.4 && < 0.6 + , unordered-containers >= 0.2.1 && < 0.3 + build-tools: alex >= 3.1 + , happy >= 1.19.4 + ghc-options: -Wall + -Wincomplete-record-updates + -Wredundant-constraints + -fno-warn-name-shadowing + -rtsopts + -- * -I0: Disable idle GC to avoid redundant GCs while + -- waiting for external processes + -- * -qg: Don't use parallel GC as the synchronization + -- time tends to eat any benefit. + "-with-rtsopts=-I0 -qg" + -threaded diff --git a/hadrian/shell.nix b/hadrian/shell.nix new file mode 100644 index 0000000000..041bf092a2 --- /dev/null +++ b/hadrian/shell.nix @@ -0,0 +1,89 @@ +# Invoking nix-shell sets up an environment where we can build ghc +# by only invoking hadrian. + + +{ _nixpkgs ? import <nixpkgs> {} }: + +let + + nixpkgs = import (_nixpkgs.fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs"; + rev = "e7a327da5cffdf5e77e1924906a4f0983591bd3e"; + sha256 = "1xzil4mayhggg2miwspbk12nihlszg0y4n6i4qacrxql5n75f0hr"; + }){ overlays = [cabalHashes]; }; + + + + cabalHashes = sel: super: { + all-cabal-hashes = super.fetchurl { + url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/b2b93ae610f5f1b51d22b191f972dc3dec8f94c6.tar.gz"; + sha256 = "0bffclpqbw62xff36qlzxghr042mhv0m06k5ml4298w6fv7ly1xw"; + }; + }; + + haskellPackages = nixpkgs.haskell.packages.ghc822; + + removeBuild = path: type: + let baseName = baseNameOf (toString path); + in + ! (baseName == "_build" + || baseName == "dist" + || baseName == "dist-newstyle" + || baseName == ".stack-work" + || baseName == "config.log" + || baseName == "config.status" + || baseName == "shell.nix" + || nixpkgs.lib.hasSuffix ".sh" baseName + || !(nixpkgs.lib.cleanSourceFilter path type)) ; + + filterSrc = path: builtins.filterSource removeBuild path; + + + hadrianPackages = nixpkgs.haskell.packages.ghc822.override { + overrides = self: super: let + localPackage = name: path: self.callCabal2nix name (filterSrc path) {}; + in { + hadrian = localPackage "hadrian" ./. ; + happy = nixpkgs.haskell.lib.dontCheck (super.happy); + shake = self.callHackage "shake" "0.16.2" {}; + extra = self.callHackage "extra" "1.6.4" {}; + QuickCheck = self.callHackage "QuickCheck" "2.10" {}; + Cabal = localPackage "Cabal" ./../libraries/Cabal/Cabal ; + filepath = localPackage "filepath" ./../libraries/filepath ; + text = localPackage "text" ./../libraries/text ; + hpc = localPackage"hpc" ./../libraries/hpc ; + parsec = localPackage "parsec" ./../libraries/parsec ; + HUnit = nixpkgs.haskell.lib.dontCheck (self.callHackage "HUnit" "1.3.1.2" {}); + process = localPackage "process" ./../libraries/process ; + directory = localPackage "directory" ./../libraries/directory ; + }; }; + + cabalPackages = nixpkgs.haskell.packages.ghc822.override { + overrides = self: super: let + localPackage = name: path: self.callCabal2nix name (filterSrc path) {}; + in { + Cabal = localPackage "Cabal" ./../../cabal/Cabal ; + cabal-install = self.callPackage ./../../cabal/cabal-install.nix {}; + }; }; + + +in + nixpkgs.lib.overrideDerivation nixpkgs.haskell.packages.ghcHEAD.ghc + (drv: { + name = "ghc-dev"; + nativeBuildInputs = drv.nativeBuildInputs ++ + [ hadrianPackages.hadrian + nixpkgs.arcanist + nixpkgs.git + nixpkgs.gmp.dev nixpkgs.gmp.out + nixpkgs.ncurses.dev nixpkgs.ncurses.out + nixpkgs.python3Packages.sphinx + nixpkgs.texlive.combined.scheme-basic + (nixpkgs.haskell.packages.ghc822.ghcWithPackages + (ps: [ps.html ps.regex-compat ps.dump-core])) + + #cabalPackages.cabal-install + ]; + }) + diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs new file mode 100644 index 0000000000..68862ed144 --- /dev/null +++ b/hadrian/src/Base.hs @@ -0,0 +1,126 @@ +module Base ( + -- * General utilities + module Control.Applicative, + module Control.Monad.Extra, + module Data.List.Extra, + module Data.Maybe, + module Data.Semigroup, + module Hadrian.Utilities, + + -- * Shake + module Development.Shake, + module Development.Shake.Classes, + module Development.Shake.FilePath, + module Development.Shake.Util, + + -- * Basic data types + module Hadrian.Package, + module Stage, + module Way, + + -- * Files + configH, ghcVersionH, + + -- * Paths + hadrianPath, configPath, configFile, sourcePath, shakeFilesDir, + generatedDir, generatedPath, stageBinPath, stageLibPath, templateHscPath, + ghcDeps, relativePackageDbPath, packageDbPath, packageDbStamp, ghcSplitPath + ) where + +import Control.Applicative +import Control.Monad.Extra +import Control.Monad.Reader +import Data.List.Extra +import Data.Maybe +import Data.Semigroup +import Development.Shake hiding (parallel, unit, (*>), Normal) +import Development.Shake.Classes +import Development.Shake.FilePath +import Development.Shake.Util +import Hadrian.Utilities +import Hadrian.Package + +import Stage +import Way + +-- | Hadrian lives in the 'hadrianPath' directory of the GHC tree. +hadrianPath :: FilePath +hadrianPath = "hadrian" + +-- TODO: Move this to build directory? +-- | Path to system configuration files, such as 'configFile'. +configPath :: FilePath +configPath = hadrianPath -/- "cfg" + +-- | Path to the system configuration file generated by the @configure@ script. +configFile :: FilePath +configFile = configPath -/- "system.config" + +-- | Path to source files of the build system, e.g. this file is located at +-- @sourcePath -/- "Base.hs"@. We use this to track some of the source files. +sourcePath :: FilePath +sourcePath = hadrianPath -/- "src" + +-- TODO: Change @mk/config.h@ to @shake-build/cfg/config.h@. +-- | Path to the generated @mk/config.h@ file. +configH :: FilePath +configH = "mk/config.h" + +ghcVersionH :: Action FilePath +ghcVersionH = generatedPath <&> (-/- "ghcversion.h") + +-- | The directory in 'buildRoot' containing the Shake database and other +-- auxiliary files generated by Hadrian. +shakeFilesDir :: FilePath +shakeFilesDir = "hadrian" + +-- | The directory in 'buildRoot' containing generated source files that are not +-- package-specific, e.g. @ghcplatform.h@. +generatedDir :: FilePath +generatedDir = "generated" + +generatedPath :: Action FilePath +generatedPath = buildRoot <&> (-/- generatedDir) + +-- | Path to the package database for a given build stage, relative to the build +-- root. Note that @StageN@, where @N > 1@, uses the 'Stage1' package database. +relativePackageDbPath :: Stage -> FilePath +relativePackageDbPath stage = stageString (min stage Stage1) -/- "lib/package.conf.d" + +-- | Path to the package database used in a given 'Stage', including +-- the build root. +packageDbPath :: Stage -> Action FilePath +packageDbPath stage = buildRoot <&> (-/- relativePackageDbPath stage) + +-- | We use a stamp file to track the existence of a package database. +packageDbStamp :: FilePath +packageDbStamp = ".stamp" + +-- | @bin@ directory for the given 'Stage' (including the build root) +stageBinPath :: Stage -> Action FilePath +stageBinPath stage = buildRoot <&> (-/- stageString stage -/- "bin") + +-- | @lib@ directory for the given 'Stage' (including the build root) +stageLibPath :: Stage -> Action FilePath +stageLibPath stage = buildRoot <&> (-/- stageString stage -/- "lib") + +-- | Files the `ghc` binary depends on +ghcDeps :: Stage -> Action [FilePath] +ghcDeps stage = mapM (\f -> stageLibPath stage <&> (-/- f)) + [ "ghc-usage.txt" + , "ghci-usage.txt" + , "llvm-targets" + , "llvm-passes" + , "platformConstants" + , "settings" ] + +-- ref: utils/hsc2hs/ghc.mk +-- | Path to 'hsc2hs' template. +templateHscPath :: Stage -> Action FilePath +templateHscPath stage = stageLibPath stage <&> (-/- "template-hsc.h") + +-- | @ghc-split@ is a Perl script used by GHC when run with @-split-objs@ flag. +-- It is generated in "Rules.Generate". This function returns the path relative +-- to the build root under which we will copy @ghc-split@. +ghcSplitPath :: Stage -> FilePath +ghcSplitPath stage = stageString stage -/- "bin" -/- "ghc-split" diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs new file mode 100644 index 0000000000..85c2c4c280 --- /dev/null +++ b/hadrian/src/Builder.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE InstanceSigs #-} +module Builder ( + -- * Data types + ArMode (..), CcMode (..), ConfigurationInfo (..), GhcMode (..), + GhcPkgMode (..), HaddockMode (..), SphinxMode (..), TarMode (..), + Builder (..), + + -- * Builder properties + builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder, + runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath, + builderEnvironment, + + -- * Ad hoc builder invocation + applyPatch + ) where + +import Development.Shake.Classes +import GHC.Generics +import qualified Hadrian.Builder as H +import Hadrian.Builder hiding (Builder) +import Hadrian.Builder.Ar +import Hadrian.Builder.Sphinx +import Hadrian.Builder.Tar +import Hadrian.Oracles.Path +import Hadrian.Oracles.TextFile +import Hadrian.Utilities + +import Base +import Context +import Oracles.Flag +import Oracles.Setting +import Packages + +-- | C compiler can be used in two different modes: +-- * Compile or preprocess a source file. +-- * Extract source dependencies by passing @-MM@ command line argument. +data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show) + +instance Binary CcMode +instance Hashable CcMode +instance NFData CcMode + +-- | GHC can be used in four different modes: +-- * Compile a Haskell source file. +-- * Compile a C source file. +-- * Extract source dependencies by passing @-M@ command line argument. +-- * Link object files & static libraries into an executable. +data GhcMode = CompileHs | CompileCWithGhc | FindHsDependencies | LinkHs + deriving (Eq, Generic, Show) + +instance Binary GhcMode +instance Hashable GhcMode +instance NFData GhcMode + +-- | To configure a package we need two pieces of information, which we choose +-- to record separately for convenience. +-- +-- * Command line arguments to be passed to the setup script. +-- +-- * Package configuration flags that enable/disable certain package features. +-- Here is an example from "Settings.Packages": +-- +-- > package rts +-- > ? builder (Cabal Flags) +-- > ? any (wayUnit Profiling) rtsWays +-- > ? arg "profiling" +-- +-- This instructs package configuration functions (such as 'configurePackage') +-- to enable the @profiling@ Cabal flag when processing @rts.cabal@ and +-- building RTS with profiling information. +data ConfigurationInfo = Setup | Flags deriving (Eq, Generic, Show) + +instance Binary ConfigurationInfo +instance Hashable ConfigurationInfo +instance NFData ConfigurationInfo + +-- TODO: Do we really need all these modes? Why do we need 'Dependencies'? We +-- can extract dependencies using the Cabal library. +-- | 'GhcPkg' can initialise a package database and register packages in it. +data GhcPkgMode = Init -- ^ Initialize a new database. + | Update -- ^ Update a package. + | Copy -- ^ Copy a package from one database to another. + | Unregister -- ^ Unregister a package. + | Dependencies -- ^ Compute package dependencies. + deriving (Eq, Generic, Show) + +instance Binary GhcPkgMode +instance Hashable GhcPkgMode +instance NFData GhcPkgMode + +-- | Haddock can be used in two different modes: +-- * Generate documentation for a single package +-- * Generate an index page for a collection of packages +data HaddockMode = BuildPackage | BuildIndex deriving (Eq, Generic, Show) + +instance Binary HaddockMode +instance Hashable HaddockMode +instance NFData HaddockMode + +-- | A 'Builder' is a (usually external) command invoked in a separate process +-- via 'cmd'. Here are some examples: +-- * 'Alex' is a lexical analyser generator that builds @Lexer.hs@ from @Lexer.x@. +-- * 'Ghc' 'Stage0' is the bootstrapping Haskell compiler used in 'Stage0'. +-- * 'Ghc' @StageN@ (N > 0) is the GHC built in stage (N - 1) and used in @StageN@. +-- +-- The 'Cabal' builder is unusual in that it does not correspond to an external +-- program but instead relies on the Cabal library for package configuration. +data Builder = Alex + | Ar ArMode Stage + | Autoreconf FilePath + | DeriveConstants + | Cabal ConfigurationInfo Stage + | Cc CcMode Stage + | Configure FilePath + | GenApply + | GenPrimopCode + | Ghc GhcMode Stage + | GhcPkg GhcPkgMode Stage + | Haddock HaddockMode + | Happy + | Hpc + | Hp2Ps + | HsCpp + | Hsc2Hs Stage + | Ld Stage + | Make FilePath + | Nm + | Objdump + | Patch + | Perl + | Python + | Ranlib + | RunTest + | Sphinx SphinxMode + | Tar TarMode + | Unlit + | Xelatex + deriving (Eq, Generic, Show) + +instance Binary Builder +instance Hashable Builder +instance NFData Builder + +-- | Some builders are built by this very build system, in which case +-- 'builderProvenance' returns the corresponding build 'Context' (which includes +-- 'Stage' and GHC 'Package'). +builderProvenance :: Builder -> Maybe Context +builderProvenance = \case + DeriveConstants -> context Stage0 deriveConstants + GenApply -> context Stage0 genapply + GenPrimopCode -> context Stage0 genprimopcode + Ghc _ Stage0 -> Nothing + Ghc _ stage -> context (pred stage) ghc + GhcPkg _ Stage0 -> Nothing + GhcPkg _ _ -> context Stage0 ghcPkg + Haddock _ -> context Stage2 haddock + Hpc -> context Stage1 hpcBin + Hp2Ps -> context Stage0 hp2ps + Hsc2Hs _ -> context Stage0 hsc2hs + Unlit -> context Stage0 unlit + _ -> Nothing + where + context s p = Just $ vanillaContext s p + +instance H.Builder Builder where + builderPath :: Builder -> Action FilePath + builderPath builder = case builderProvenance builder of + Nothing -> systemBuilderPath builder + Just context -> programPath context + + runtimeDependencies :: Builder -> Action [FilePath] + runtimeDependencies = \case + Autoreconf dir -> return [dir -/- "configure.ac"] + Configure dir -> return [dir -/- "configure"] + + Ghc _ Stage0 -> return [] + Ghc _ stage -> do + root <- buildRoot + win <- windowsHost + touchyPath <- programPath (vanillaContext Stage0 touchy) + unlitPath <- builderPath Unlit + ghcdeps <- ghcDeps stage + return $ [ root -/- ghcSplitPath stage -- TODO: Make conditional on --split-objects + , unlitPath ] + ++ ghcdeps + ++ [ touchyPath | win ] + + Hsc2Hs stage -> (\p -> [p]) <$> templateHscPath stage + Make dir -> return [dir -/- "Makefile"] + _ -> return [] + + -- query the builder for some information. + -- contrast this with runBuilderWith, which returns @Action ()@ + -- this returns the @stdout@ from running the builder. + -- For now this only implements asking @ghc-pkg@ about package + -- dependencies. + askBuilderWith :: Builder -> BuildInfo -> Action String + askBuilderWith builder BuildInfo {..} = case builder of + GhcPkg Dependencies _ -> do + let input = fromSingleton msgIn buildInputs + msgIn = "[askBuilder] Exactly one input file expected." + needBuilder builder + path <- H.builderPath builder + need [path] + Stdout stdout <- cmd [path] ["--no-user-package-db", "field", input, "depends"] + return stdout + _ -> error $ "Builder " ++ show builder ++ " can not be asked!" + + runBuilderWith :: Builder -> BuildInfo -> Action () + runBuilderWith builder BuildInfo {..} = do + path <- builderPath builder + withResources buildResources $ do + verbosity <- getVerbosity + let input = fromSingleton msgIn buildInputs + msgIn = "[runBuilderWith] Exactly one input file expected." + output = fromSingleton msgOut buildOutputs + msgOut = "[runBuilderWith] Exactly one output file expected." + -- Suppress stdout depending on the Shake's verbosity setting. + echo = EchoStdout (verbosity >= Loud) + -- Capture stdout and write it to the output file. + captureStdout = do + Stdout stdout <- cmd [path] buildArgs + writeFileChanged output stdout + case builder of + Ar Pack _ -> do + useTempFile <- flag ArSupportsAtFile + if useTempFile then runAr path buildArgs + else runArWithoutTempFile path buildArgs + + Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs + + Autoreconf dir -> cmd echo [Cwd dir] [path] buildArgs + Configure dir -> do + -- Inject /bin/bash into `libtool`, instead of /bin/sh, + -- otherwise Windows breaks. TODO: Figure out why. + bash <- bashPath + let env = AddEnv "CONFIG_SHELL" bash + cmd echo env [Cwd dir] ["sh", path] buildOptions buildArgs + + HsCpp -> captureStdout + GenApply -> captureStdout + + GenPrimopCode -> do + stdin <- readFile' input + Stdout stdout <- cmd (Stdin stdin) [path] buildArgs + writeFileChanged output stdout + + Make dir -> cmd echo path ["-C", dir] buildArgs + + Xelatex -> do + unit $ cmd [Cwd output] [path] buildArgs + unit $ cmd [Cwd output] [path] buildArgs + unit $ cmd [Cwd output] [path] buildArgs + unit $ cmd [Cwd output] ["makeindex"] (input -<.> "idx") + unit $ cmd [Cwd output] [path] buildArgs + unit $ cmd [Cwd output] [path] buildArgs + + GhcPkg Copy _ -> do + Stdout pkgDesc <- cmd [path] + [ "--expand-pkgroot" + , "--no-user-package-db" + , "describe" + , input -- the package name + ] + cmd (Stdin pkgDesc) [path] (buildArgs ++ ["-"]) + + GhcPkg Unregister _ -> do + Exit _ <- cmd echo [path] (buildArgs ++ [input]) + return () + + _ -> cmd echo [path] buildArgs + +-- TODO: Some builders are required only on certain platforms. For example, +-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform +-- specific optional builders as soon as we can reliably test this feature. +-- See https://github.com/snowleopard/hadrian/issues/211. +isOptional :: Builder -> Bool +isOptional = \case + Objdump -> True + _ -> False + +-- | Determine the location of a system 'Builder'. +systemBuilderPath :: Builder -> Action FilePath +systemBuilderPath builder = case builder of + Alex -> fromKey "alex" + Ar _ Stage0 -> fromKey "system-ar" + Ar _ _ -> fromKey "ar" + Autoreconf _ -> fromKey "autoreconf" + Cc _ Stage0 -> fromKey "system-cc" + Cc _ _ -> fromKey "cc" + -- We can't ask configure for the path to configure! + Configure _ -> return "configure" + Ghc _ Stage0 -> fromKey "system-ghc" + GhcPkg _ Stage0 -> fromKey "system-ghc-pkg" + Happy -> fromKey "happy" + HsCpp -> fromKey "hs-cpp" + Ld _ -> fromKey "ld" + Make _ -> fromKey "make" + Nm -> fromKey "nm" + Objdump -> fromKey "objdump" + Patch -> fromKey "patch" + Perl -> fromKey "perl" + Python -> fromKey "python" + Ranlib -> fromKey "ranlib" + RunTest -> fromKey "python" + Sphinx _ -> fromKey "sphinx-build" + Tar _ -> fromKey "tar" + Xelatex -> fromKey "xelatex" + _ -> error $ "No entry for " ++ show builder ++ inCfg + where + inCfg = " in " ++ quote configFile ++ " file." + fromKey key = do + let unpack = fromMaybe . error $ "Cannot find path to builder " + ++ quote key ++ inCfg ++ " Did you skip configure?" + path <- unpack <$> lookupValue configFile key + if null path + then do + unless (isOptional builder) . error $ "Non optional builder " + ++ quote key ++ " is not specified" ++ inCfg + return "" -- TODO: Use a safe interface. + else do + win <- windowsHost + fullPath <- lookupInPath path + case (win, hasExtension fullPath) of + (False, _ ) -> return fullPath + (True , True ) -> fixAbsolutePathOnWindows fullPath + (True , False) -> fixAbsolutePathOnWindows fullPath <&> (<.> exe) + +-- | Was the path to a given system 'Builder' specified in configuration files? +isSpecified :: Builder -> Action Bool +isSpecified = fmap (not . null) . systemBuilderPath + +-- | Apply a patch by executing the 'Patch' builder in a given directory. +applyPatch :: FilePath -> FilePath -> Action () +applyPatch dir patch = do + let file = dir -/- patch + needBuilder Patch + path <- builderPath Patch + putBuild $ "| Apply patch " ++ file + quietly $ cmd [Cwd dir, FileStdin file] [path, "-p0"] diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs new file mode 100644 index 0000000000..1532ec51d7 --- /dev/null +++ b/hadrian/src/CommandLine.hs @@ -0,0 +1,258 @@ +module CommandLine ( + optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple, + cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdSplitObjects, + lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs + ) where + +import Data.Either +import qualified Data.HashMap.Strict as Map +import Data.List.Extra +import Development.Shake hiding (Normal) +import Hadrian.Utilities hiding (buildRoot) +import System.Console.GetOpt +import System.Environment + +data TestSpeed = Slow | Average | Fast deriving (Show, Eq) + +-- | All arguments that can be passed to Hadrian via the command line. +data CommandLineArgs = CommandLineArgs + { configure :: Bool + , flavour :: Maybe String + , freeze1 :: Bool + , integerSimple :: Bool + , progressColour :: UseColour + , progressInfo :: ProgressInfo + , splitObjects :: Bool + , buildRoot :: BuildRoot + , testArgs :: TestArgs } + deriving (Eq, Show) + +-- | Default values for 'CommandLineArgs'. +defaultCommandLineArgs :: CommandLineArgs +defaultCommandLineArgs = CommandLineArgs + { configure = False + , flavour = Nothing + , freeze1 = False + , integerSimple = False + , progressColour = Auto + , progressInfo = Brief + , splitObjects = False + , buildRoot = BuildRoot "_build" + , testArgs = defaultTestArgs } + +-- | These arguments are used by the `test` target. +data TestArgs = TestArgs + { testCompiler :: String + , testConfigFile :: String + , testConfigs :: [String] + , testJUnit :: Maybe FilePath + , testOnly :: Maybe String + , testOnlyPerf :: Bool + , testSkipPerf :: Bool + , testSpeed :: TestSpeed + , testSummary :: Maybe FilePath + , testVerbosity :: Maybe String + , testWays :: [String] } + deriving (Eq, Show) + +-- | Default value for `TestArgs`. +defaultTestArgs :: TestArgs +defaultTestArgs = TestArgs + { testCompiler = "stage2" + , testConfigFile = "testsuite/config/ghc" + , testConfigs = [] + , testJUnit = Nothing + , testOnly = Nothing + , testOnlyPerf = False + , testSkipPerf = False + , testSpeed = Fast + , testSummary = Nothing + , testVerbosity = Nothing + , testWays = [] } + +readConfigure :: Either String (CommandLineArgs -> CommandLineArgs) +readConfigure = Right $ \flags -> flags { configure = True } + +readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms } + +readBuildRoot :: Maybe FilePath -> Either String (CommandLineArgs -> CommandLineArgs) +readBuildRoot ms = + maybe (Left "Cannot parse build-root") (Right . set) (go =<< ms) + where + go :: String -> Maybe BuildRoot + go = Just . BuildRoot + set :: BuildRoot -> CommandLineArgs -> CommandLineArgs + set flag flags = flags { buildRoot = flag } + +readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs) +readFreeze1 = Right $ \flags -> flags { freeze1 = True } + +readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs) +readIntegerSimple = Right $ \flags -> flags { integerSimple = True } + +readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readProgressColour ms = + maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms) + where + go :: String -> Maybe UseColour + go "never" = Just Never + go "auto" = Just Auto + go "always" = Just Always + go _ = Nothing + set :: UseColour -> CommandLineArgs -> CommandLineArgs + set flag flags = flags { progressColour = flag } + +readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readProgressInfo ms = + maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms) + where + go :: String -> Maybe ProgressInfo + go "none" = Just None + go "brief" = Just Brief + go "normal" = Just Normal + go "unicorn" = Just Unicorn + go _ = Nothing + set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs + set flag flags = flags { progressInfo = flag } + +readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs) +readSplitObjects = Right $ \flags -> flags { splitObjects = True } + +readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler + where + set compiler = \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } } + +readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestConfig config = + case config of + Nothing -> Right id + Just conf -> Right $ \flags -> + let configs = conf : testConfigs (testArgs flags) + in flags { testArgs = (testArgs flags) { testConfigs = configs } } + +readTestConfigFile :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestConfigFile filepath = + maybe (Left "Cannot parse test-speed") (Right . set) filepath + where + set filepath flags = flags { testArgs = (testArgs flags) { testConfigFile = filepath } } + +readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } } + +readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestOnly tests = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnly = tests } } + +readTestOnlyPerf :: Either String (CommandLineArgs -> CommandLineArgs) +readTestOnlyPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnlyPerf = True } } + +readTestSkipPerf :: Either String (CommandLineArgs -> CommandLineArgs) +readTestSkipPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testSkipPerf = True } } + +readTestSpeed :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestSpeed ms = + maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms) + where + go :: String -> Maybe TestSpeed + go "fast" = Just Fast + go "slow" = Just Slow + go "average" = Just Average + go _ = Nothing + set :: TestSpeed -> CommandLineArgs -> CommandLineArgs + set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} } + +readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } } + +readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } } + +readTestWay :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readTestWay way = + case way of + Nothing -> Right id + Just way -> Right $ \flags -> + let newWays = way : testWays (testArgs flags) + in flags { testArgs = (testArgs flags) {testWays = newWays} } + +-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments. +optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))] +optDescrs = + [ Option ['c'] ["configure"] (NoArg readConfigure) + "Run the boot and configure scripts (if you do not want to run them manually)." + , Option ['o'] ["build-root"] (OptArg readBuildRoot "BUILD_ROOT") + "Where to store build artifacts. (Default _build)." + , Option [] ["flavour"] (OptArg readFlavour "FLAVOUR") + "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)." + , Option [] ["freeze1"] (NoArg readFreeze1) + "Freeze Stage1 GHC." + , Option [] ["integer-simple"] (NoArg readIntegerSimple) + "Build GHC with integer-simple library." + , Option [] ["progress-colour"] (OptArg readProgressColour "MODE") + "Use colours in progress info (Never, Auto or Always)." + , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE") + "Progress info style (None, Brief, Normal or Unicorn)." + , Option [] ["split-objects"] (NoArg readSplitObjects) + "Generate split objects (requires a full clean rebuild)." + , Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER") + "Use given compiler [Default=stage2]." + , Option [] ["test-config-file"] (OptArg readTestConfigFile "CONFIG_FILE") + "congiguration file for testsuite. Default=testsuite/config/ghc" + , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG") + "Configurations to run test, in key=value format." + , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT") + "Output testsuite summary in JUnit format." + , Option [] ["only"] (OptArg readTestOnly "TESTS") + "Test cases to run." + , Option [] ["only-perf"] (NoArg readTestOnlyPerf) + "Only run performance tests." + , Option [] ["skip-perf"] (NoArg readTestSkipPerf) + "Skip performance tests." + , Option [] ["test-speed"] (OptArg readTestSpeed "SPEED") + "fast, slow or normal. Normal by default" + , Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY") + "Where to output the test summary file." + , Option [] ["test-verbose"] (OptArg readTestVerbose "TEST_VERBOSE") + "A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output." + , Option [] ["test-way"] (OptArg readTestWay "TEST_WAY") + "only run these ways" ] + +-- | A type-indexed map containing Hadrian command line arguments to be passed +-- to Shake via 'shakeExtra'. +cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic) +cmdLineArgsMap = do + (opts, _, _) <- getOpt Permute optDescrs <$> getArgs + let args = foldl (flip id) defaultCommandLineArgs (rights opts) + return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities + $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities + $ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities + $ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest + $ insertExtra args Map.empty + +cmdLineArgs :: Action CommandLineArgs +cmdLineArgs = userSetting defaultCommandLineArgs + +cmdConfigure :: Action Bool +cmdConfigure = configure <$> cmdLineArgs + +cmdFlavour :: Action (Maybe String) +cmdFlavour = flavour <$> cmdLineArgs + +lookupBuildRoot :: Map.HashMap TypeRep Dynamic -> BuildRoot +lookupBuildRoot = buildRoot . lookupExtra defaultCommandLineArgs + +lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool +lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs + +cmdIntegerSimple :: Action Bool +cmdIntegerSimple = integerSimple <$> cmdLineArgs + +cmdProgressColour :: Action UseColour +cmdProgressColour = progressColour <$> cmdLineArgs + +cmdProgressInfo :: Action ProgressInfo +cmdProgressInfo = progressInfo <$> cmdLineArgs + +cmdSplitObjects :: Action Bool +cmdSplitObjects = splitObjects <$> cmdLineArgs diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs new file mode 100644 index 0000000000..3269714c29 --- /dev/null +++ b/hadrian/src/Context.hs @@ -0,0 +1,112 @@ +module Context ( + -- * Context + Context (..), vanillaContext, stageContext, + + -- * Expressions + getStage, getPackage, getWay, getStagedSettingList, getBuildPath, + + -- * Paths + contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, + pkgHaddockFile, pkgLibraryFile, pkgGhciLibraryFile, pkgConfFile, objectPath, + contextPath, getContextPath, libDir, libPath + ) where + +import Base +import Context.Path +import Context.Type +import Hadrian.Expression +import Hadrian.Haskell.Cabal +import Oracles.Setting + +-- | Most targets are built only one way, hence the notion of 'vanillaContext'. +vanillaContext :: Stage -> Package -> Context +vanillaContext s p = Context s p vanilla + +-- | Partial context with undefined 'Package' field. Useful for 'Packages' +-- expressions that only read the environment and current 'Stage'. +stageContext :: Stage -> Context +stageContext s = vanillaContext s $ error "stageContext: package not set" + +-- | Get the 'Stage' of the current 'Context'. +getStage :: Expr Context b Stage +getStage = stage <$> getContext + +-- | Get the 'Package' of the current 'Context'. +getPackage :: Expr Context b Package +getPackage = package <$> getContext + +-- | Get the 'Way' of the current 'Context'. +getWay :: Expr Context b Way +getWay = way <$> getContext + +-- | Get a list of configuration settings for the current stage. +getStagedSettingList :: (Stage -> SettingList) -> Args Context b +getStagedSettingList f = getSettingList . f =<< getStage + +libDir :: Context -> FilePath +libDir Context {..} = stageString stage -/- "lib" + +-- | Path to the directory containg the final artifact in a given 'Context' +libPath :: Context -> Action FilePath +libPath context = buildRoot <&> (-/- libDir context) + +pkgFile :: Context -> String -> String -> Action FilePath +pkgFile context@Context {..} prefix suffix = do + path <- buildPath context + pid <- pkgIdentifier package + return $ path -/- prefix ++ pid ++ suffix + +-- | Path to inplace package configuration file of a given 'Context'. +pkgInplaceConfig :: Context -> Action FilePath +pkgInplaceConfig context = do + path <- contextPath context + return $ path -/- "inplace-pkg-config" + +-- TODO: Add a @Rules FilePath@ alternative. +-- | Path to the @setup-config@ of a given 'Context'. +pkgSetupConfigFile :: Context -> Action FilePath +pkgSetupConfigFile context = do + path <- contextPath context + return $ path -/- "setup-config" + +-- | Path to the haddock file of a given 'Context', e.g.: +-- @_build/stage1/libraries/array/doc/html/array/array.haddock@. +pkgHaddockFile :: Context -> Action FilePath +pkgHaddockFile Context {..} = do + root <- buildRoot + let name = pkgName package + return $ root -/- "docs/html/libraries" -/- name -/- name <.> "haddock" + +-- | Path to the library file of a given 'Context', e.g.: +-- @_build/stage1/libraries/array/build/libHSarray-0.5.1.0.a@. +pkgLibraryFile :: Context -> Action FilePath +pkgLibraryFile context@Context {..} = do + extension <- libsuf way + pkgFile context "libHS" extension + +-- | Path to the GHCi library file of a given 'Context', e.g.: +-- @_build/stage1/libraries/array/build/HSarray-0.5.1.0.o@. +pkgGhciLibraryFile :: Context -> Action FilePath +pkgGhciLibraryFile context = pkgFile context "HS" ".o" + +-- | Path to the configuration file of a given 'Context'. +pkgConfFile :: Context -> Action FilePath +pkgConfFile Context {..} = do + root <- buildRoot + pid <- pkgIdentifier package + return $ root -/- relativePackageDbPath stage -/- pid <.> "conf" + +-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath' +-- to its object file. For example: +-- * "Task.c" -> "_build/stage1/rts/Task.thr_o" +-- * "_build/stage1/rts/cmm/AutoApply.cmm" -> "_build/stage1/rts/cmm/AutoApply.o" +objectPath :: Context -> FilePath -> Action FilePath +objectPath context@Context {..} src = do + isGenerated <- isGeneratedSource src + path <- buildPath context + let extension = drop 1 $ takeExtension src + obj = src -<.> osuf way + result | isGenerated = obj + | "*hs*" ?== extension = path -/- obj + | otherwise = path -/- extension -/- obj + return result diff --git a/hadrian/src/Context/Path.hs b/hadrian/src/Context/Path.hs new file mode 100644 index 0000000000..4bc9d9be34 --- /dev/null +++ b/hadrian/src/Context/Path.hs @@ -0,0 +1,43 @@ +module Context.Path where + +import Base +import Context.Type +import Hadrian.Expression + +-- | The build directory of the current 'Stage'. +stageDir :: Context -> FilePath +stageDir Context {..} = stageString stage + +-- | The build path of the current 'Stage'. +stagePath :: Context -> Action FilePath +stagePath context = buildRoot <&> (-/- stageDir context) + +-- | The expression that evaluates to the build path of the current 'Stage'. +getStagePath :: Expr Context b FilePath +getStagePath = expr . stagePath =<< getContext + +-- | The directory in 'buildRoot' containing build artifacts of a given 'Context'. +contextDir :: Context -> FilePath +contextDir Context {..} = stageString stage -/- pkgPath package + +-- | The path to the directory in 'buildRoot' containing build artifacts of a +-- given 'Context'. +contextPath :: Context -> Action FilePath +contextPath context = buildRoot <&> (-/- contextDir context) + +-- | The expression that evaluates to the path to the directory in 'buildRoot' +-- containing build artifacts of a given 'Context'. +getContextPath :: Expr Context b FilePath +getContextPath = expr . contextPath =<< getContext + +-- | The directory in 'buildRoot' containing the object artifacts. +buildDir :: Context -> FilePath +buildDir context = contextDir context -/- "build" + +-- | Path to the directory containing build artifacts of a given 'Context'. +buildPath :: Context -> Action FilePath +buildPath context = buildRoot <&> (-/- buildDir context) + +-- | The expression that evaluates to the build path of the current 'Context'. +getBuildPath :: Expr Context b FilePath +getBuildPath = expr . buildPath =<< getContext diff --git a/hadrian/src/Context/Type.hs b/hadrian/src/Context/Type.hs new file mode 100644 index 0000000000..4ce622efed --- /dev/null +++ b/hadrian/src/Context/Type.hs @@ -0,0 +1,20 @@ +module Context.Type where + +import Development.Shake.Classes +import GHC.Generics +import Hadrian.Package + +import Stage +import Way.Type + +-- | Build context for a currently built 'Target'. We generate potentially +-- different build rules for each 'Context'. +data Context = Context + { stage :: Stage -- ^ Currently build Stage + , package :: Package -- ^ Currently build Package + , way :: Way -- ^ Currently build Way (usually 'vanilla') + } deriving (Eq, Generic, Show) + +instance Binary Context +instance Hashable Context +instance NFData Context diff --git a/hadrian/src/Environment.hs b/hadrian/src/Environment.hs new file mode 100644 index 0000000000..1666c68322 --- /dev/null +++ b/hadrian/src/Environment.hs @@ -0,0 +1,16 @@ +module Environment (setupEnvironment) where + +import System.Environment + +-- | The build system invokes many external builders whose behaviour is +-- influenced by the environment variables. We need to modify some of them +-- for better robustness of the build system. +setupEnvironment :: IO () +setupEnvironment = do + -- Cabal refuses to work when GHC_PACKAGE_PATH is set (e.g. by Stack) + unsetEnv "GHC_PACKAGE_PATH" + + -- in MinGW if PWD is set to a Windows "C:\\" style path then configure + -- `pwd` will return the Windows path, and then modifying $PATH will fail. + -- See https://github.com/snowleopard/hadrian/issues/189 for details. + unsetEnv "PWD" diff --git a/hadrian/src/Expression.hs b/hadrian/src/Expression.hs new file mode 100644 index 0000000000..a520c0ba5d --- /dev/null +++ b/hadrian/src/Expression.hs @@ -0,0 +1,108 @@ +module Expression ( + -- * Expressions + Expr, Predicate, Args, Ways, + + -- ** Construction and modification + expr, exprIO, arg, remove, + + -- ** Predicates + (?), stage, stage0, stage1, stage2, notStage0, package, notPackage, + libraryPackage, builder, way, input, inputs, output, outputs, + + -- ** Evaluation + interpret, interpretInContext, + + -- * Convenient accessors + getBuildRoot, getContext, getOutputs, getInputs, + getInput, getOutput, getContextData, + + -- * Re-exports + module Base, + module Builder, + module Context, + ) where + +import Base +import Builder +import Context hiding (stage, package, way) +import Expression.Type +import Hadrian.Expression hiding (Expr, Predicate, Args) +import Hadrian.Haskell.Cabal.Type +import Hadrian.Oracles.Cabal + +-- | Get values from a configured cabal stage. +getContextData :: (ContextData -> a) -> Expr a +getContextData key = do + contextData <- expr . readContextData =<< getContext + return $ key contextData + +-- | Is the build currently in the provided stage? +stage :: Stage -> Predicate +stage s = (s ==) <$> getStage + +-- | Is a particular package being built? +package :: Package -> Predicate +package p = (p ==) <$> getPackage + +-- | This type class allows the user to construct both precise builder +-- predicates, such as @builder (Ghc CompileHs Stage1)@, as well as predicates +-- covering a set of similar builders. For example, @builder (Ghc CompileHs)@ +-- matches any stage, and @builder Ghc@ matches any stage and any GHC mode. +class BuilderPredicate a where + -- | Is a particular builder being used? + builder :: a -> Predicate + +instance BuilderPredicate Builder where + builder b = (b ==) <$> getBuilder + +instance BuilderPredicate a => BuilderPredicate (Stage -> a) where + builder f = builder . f =<< getStage + +instance BuilderPredicate a => BuilderPredicate (CcMode -> a) where + builder f = do + b <- getBuilder + case b of + Cc c _ -> builder (f c) + _ -> return False + +instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where + builder f = do + b <- getBuilder + case b of + Ghc c _ -> builder (f c) + _ -> return False + +instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where + builder f = do + b <- getBuilder + case b of + Configure path -> builder (f path) + _ -> return False + +-- | Is the current build 'Way' equal to a certain value? +way :: Way -> Predicate +way w = (w ==) <$> getWay + +-- | Is the build currently in stage 0? +stage0 :: Predicate +stage0 = stage Stage0 + +-- | Is the build currently in stage 1? +stage1 :: Predicate +stage1 = stage Stage1 + +-- | Is the build currently in stage 2? +stage2 :: Predicate +stage2 = stage Stage2 + +-- | Is the build /not/ in stage 0 right now? +notStage0 :: Predicate +notStage0 = notM stage0 + +-- | Is a certain package /not/ built right now? +notPackage :: Package -> Predicate +notPackage = notM . package + +-- | Is a library package currently being built? +libraryPackage :: Predicate +libraryPackage = isLibrary <$> getPackage diff --git a/hadrian/src/Expression/Type.hs b/hadrian/src/Expression/Type.hs new file mode 100644 index 0000000000..b5b0138f0a --- /dev/null +++ b/hadrian/src/Expression/Type.hs @@ -0,0 +1,18 @@ +module Expression.Type where + +import Context.Type +import Way.Type + +import Builder +import qualified Hadrian.Expression as H + +-- | @Expr a@ is a computation that produces a value of type @Action a@ and can +-- read parameters of the current build 'Target'. +type Expr a = H.Expr Context Builder a + +-- | The following expressions are used throughout the build system for +-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways' +-- and 'Packages'. +type Predicate = H.Predicate Context Builder +type Args = H.Args Context Builder +type Ways = Expr [Way] diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs new file mode 100644 index 0000000000..e95e0d7e1f --- /dev/null +++ b/hadrian/src/Flavour.hs @@ -0,0 +1,34 @@ +module Flavour (Flavour (..)) where + +import Expression + +-- Please update doc/{flavours.md, user-settings.md} when changing this file. +-- | 'Flavour' is a collection of build settings that fully define a GHC build. +-- Note the following type semantics: +-- * @Bool@: a plain Boolean flag whose value is known at compile time. +-- * @Action Bool@: a flag whose value can depend on the build environment. +-- * @Predicate@: a flag whose value can depend on the build environment and +-- on the current build target. +data Flavour = Flavour { + -- | Flavour name, to select this flavour from command line. + name :: String, + -- | Use these command line arguments. + args :: Args, + -- | Build these packages. + packages :: Stage -> Action [Package], + -- | Either 'integerGmp' or 'integerSimple'. + integerLibrary :: Action Package, + -- | Build libraries these ways. + libraryWays :: Ways, + -- | Build RTS these ways. + rtsWays :: Ways, + -- | Build split objects. + splitObjects :: Predicate, + -- | Build dynamic GHC programs. + dynamicGhcPrograms :: Action Bool, + -- | Enable GHCi debugger. + ghciWithDebugger :: Bool, + -- | Build profiled GHC. + ghcProfiled :: Bool, + -- | Build GHC with debug information. + ghcDebugged :: Bool } diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs new file mode 100644 index 0000000000..5d645eea8c --- /dev/null +++ b/hadrian/src/Hadrian/Builder.hs @@ -0,0 +1,157 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Builder +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- A typical build system invokes several build tools, or /builders/, such as +-- compilers, linkers, etc., some of which may be built by the build system +-- itself. This module defines the 'Builder' type class and a few associated +-- functions that can be used to invoke builders. +----------------------------------------------------------------------------- +module Hadrian.Builder ( + Builder (..), BuildInfo (..), needBuilder, runBuilder, + runBuilderWithCmdOptions, build, buildWithResources, buildWithCmdOptions, + getBuilderPath, builderEnvironment, askWithResources + ) where + +import Data.List +import Development.Shake + +import Hadrian.Expression hiding (inputs, outputs) +import Hadrian.Oracles.ArgsHash +import Hadrian.Target +import Hadrian.Utilities + +-- | This data structure captures all information relevant to invoking a builder. +data BuildInfo = BuildInfo { + -- | Command line arguments. + buildArgs :: [String], + -- | Input files. + buildInputs :: [FilePath], + -- | Output files. + buildOutputs :: [FilePath], + -- | Options to be passed to Shake's 'cmd' function. + buildOptions :: [CmdOption], + -- | Resources to be aquired. + buildResources :: [(Resource, Int)] } + +class ShakeValue b => Builder b where + -- | The path to a builder. + builderPath :: b -> Action FilePath + + -- | Ask the builder for information. + -- E.g. ask @ghc-pkg@ for package dependencies + -- capture the @stdout@ result and return it. + askBuilderWith :: b -> BuildInfo -> Action String + + -- | Runtime dependencies of a builder. For example, on Windows GHC requires + -- the utility @touchy.exe@ to be avilable on a specific path. + runtimeDependencies :: b -> Action [FilePath] + runtimeDependencies _ = return [] + + -- | Run a builder with a given 'BuildInfo'. Also see 'runBuilder'. + runBuilderWith :: b -> BuildInfo -> Action () + runBuilderWith builder buildInfo = do + let args = buildArgs buildInfo + needBuilder builder + path <- builderPath builder + let msg = if null args then "" else " (" ++ intercalate ", " args ++ ")" + putBuild $ "| Run " ++ show builder ++ msg + quietly $ cmd (buildOptions buildInfo) [path] args + +-- | Make sure a builder and its runtime dependencies are up-to-date. +needBuilder :: Builder b => b -> Action () +needBuilder builder = do + path <- builderPath builder + deps <- runtimeDependencies builder + need (path : deps) + +-- | Run a builder with a specified list of command line arguments, reading a +-- list of input files and writing a list of output files. A lightweight version +-- of 'runBuilderWith'. +runBuilder :: Builder b => b -> [String] -> [FilePath] -> [FilePath] -> Action () +runBuilder = runBuilderWithCmdOptions [] + +-- | Like 'runBuilder' but passes given options to Shake's 'cmd'. +runBuilderWithCmdOptions :: Builder b => [CmdOption] -> b -> [String] -> [FilePath] -> [FilePath] -> Action () +runBuilderWithCmdOptions opts builder args inputs outputs = + runBuilderWith builder $ BuildInfo { buildArgs = args + , buildInputs = inputs + , buildOutputs = outputs + , buildOptions = opts + , buildResources = [] } + +-- | Build a 'Target' using the list of command line arguments computed from a +-- given 'Args' expression. Force a rebuild if the argument list has changed +-- since the last build. +build :: (Builder b, ShakeValue c) => Target c b -> Args c b -> Action () +build = buildWith [] [] + +-- | Like 'build' but acquires necessary resources. +buildWithResources :: (Builder b, ShakeValue c) => [(Resource, Int)] -> Target c b -> Args c b -> Action () +buildWithResources rs = buildWith rs [] + +askWithResources :: (Builder b, ShakeValue c) => [(Resource, Int)] -> Target c b -> Args c b -> Action String +askWithResources rs = askWith rs [] + +-- | Like 'build' but passes given options to Shake's 'cmd'. +buildWithCmdOptions :: (Builder b, ShakeValue c) => [CmdOption] -> Target c b -> Args c b -> Action () +buildWithCmdOptions = buildWith [] + +doWith :: (Builder b, ShakeValue c) + => (b -> BuildInfo -> Action a) + -> (Target c b -> Action ()) + -> [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action a +doWith f info rs opts target args = do + needBuilder (builder target) + argList <- interpret target args + trackArgsHash target -- Rerun the rule if the hash of argList has changed. + info target + verbose <- interpret target verboseCommand + let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly + quietlyUnlessVerbose $ f (builder target) $ + BuildInfo { buildArgs = argList + , buildInputs = inputs target + , buildOutputs = outputs target + , buildOptions = opts + , buildResources = rs } + +buildWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action () +buildWith = doWith runBuilderWith runInfo + +askWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action String +askWith = doWith askBuilderWith askInfo + +-- | Print out information about the command being executed. +runInfo :: Show b => Target c b -> Action () +runInfo t = putProgressInfo =<< renderAction + ("Run " ++ show (builder t)) -- TODO: Bring back contextInfo. + (digest $ inputs t) + (digest $ outputs t) + where + digest [] = "none" + digest [x] = x + digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)" + +askInfo :: Show b => Target c b -> Action () +askInfo t = putProgressInfo =<< renderActionNoOutput + ("Run " ++ show (builder t)) -- TODO: Bring back contextInfo. + (digest $ inputs t) + where + digest [] = "none" + digest [x] = x + digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)" + +-- | Get the path to the current builder. +getBuilderPath :: Builder b => b -> Expr c b FilePath +getBuilderPath = expr . builderPath + +-- | Write a builder path into a given environment variable. +builderEnvironment :: Builder b => String -> b -> Action CmdOption +builderEnvironment variable builder = do + needBuilder builder + path <- builderPath builder + return $ AddEnv variable path diff --git a/hadrian/src/Hadrian/Builder/Ar.hs b/hadrian/src/Hadrian/Builder/Ar.hs new file mode 100644 index 0000000000..ad74653db0 --- /dev/null +++ b/hadrian/src/Hadrian/Builder/Ar.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Builder.Ar +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Support for invoking the archiving utility @ar@. We take care not to exceed +-- the limit on command line length, which differs across supported operating +-- systems (see 'cmdLineLengthLimit'). We need to handle @ar@ in a special way +-- because we sometimes archive __a lot__ of files (in the Cabal library, for +-- example, command line length can reach 2MB!). To work around the limit on the +-- command line length we pass the list of files to be archived via a temporary +-- file (see 'runAr'), or alternatively, we split the argument list into chunks +-- and call @ar@ multiple times, e.g. when passing arguments via a temporary +-- file is not supported (see 'runArWithoutTempFile'). +----------------------------------------------------------------------------- +module Hadrian.Builder.Ar (ArMode (..), args, runAr, runArWithoutTempFile) where + +import Control.Monad +import Development.Shake +import Development.Shake.Classes +import GHC.Generics +import Hadrian.Expression +import Hadrian.Utilities + +-- | We support packing and unpacking archives with @ar@. +data ArMode = Pack | Unpack deriving (Eq, Generic, Show) + +instance Binary ArMode +instance Hashable ArMode +instance NFData ArMode + +-- NOTE: Make sure to appropriately update 'arFlagsCount' when changing 'args'. +-- | Default command line arguments for invoking the archiving utility @ar@. +args :: (ShakeValue c, ShakeValue b) => ArMode -> Args c b +args Pack = mconcat [ arg "q", arg =<< getOutput, getInputs ] +args Unpack = mconcat [ arg "x", arg =<< getInput ] + +-- This count includes "q" and the output file argumentes in 'args'. This is +-- only relevant for the 'Pack' @ar@ mode. +arFlagsCount :: Int +arFlagsCount = 2 + +-- | Invoke @ar@ given a path to it and a list of arguments. The list of files +-- to be archived is passed via a temporary file. Passing arguments via a +-- temporary file is not supported by some versions of @ar@, in which case you +-- should use 'runArWithoutTempFile' instead. +runAr :: FilePath -> [String] -> Action () +runAr arPath argList = withTempFile $ \tmp -> do + writeFile' tmp $ unwords fileArgs + cmd [arPath] flagArgs ('@' : tmp) + where + flagArgs = take arFlagsCount argList + fileArgs = drop arFlagsCount argList + +-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@ +-- will be called multiple times if the list of files to be archived is too +-- long and doesn't fit into the command line length limit. This function is +-- typically much slower than 'runAr'. +runArWithoutTempFile :: FilePath -> [String] -> Action () +runArWithoutTempFile arPath argList = + forM_ (chunksOfSize cmdLineLengthLimit fileArgs) $ \argsChunk -> + unit . cmd [arPath] $ flagArgs ++ argsChunk + where + flagArgs = take arFlagsCount argList + fileArgs = drop arFlagsCount argList diff --git a/hadrian/src/Hadrian/Builder/Sphinx.hs b/hadrian/src/Hadrian/Builder/Sphinx.hs new file mode 100644 index 0000000000..44b522c4d3 --- /dev/null +++ b/hadrian/src/Hadrian/Builder/Sphinx.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Builder.Sphinx +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Support for invoking the documentation utility Sphinx. +----------------------------------------------------------------------------- +module Hadrian.Builder.Sphinx (SphinxMode (..), args) where + +import Development.Shake +import Development.Shake.Classes +import GHC.Generics +import Hadrian.Expression +import Hadrian.Utilities + +-- | Sphinx can be used in three different modes to convert reStructuredText +-- documents into HTML, LaTeX or Man pages. +data SphinxMode = Html | Latex | Man deriving (Eq, Generic, Show) + +instance Binary SphinxMode +instance Hashable SphinxMode +instance NFData SphinxMode + +-- | Default command line arguments for invoking the archiving utility @tar@. +args :: (ShakeValue c, ShakeValue b) => SphinxMode -> Args c b +args mode = do + outPath <- getOutput + mconcat [ arg "-b", arg modeString + , arg "-d", arg $ outPath -/- (".doctrees-" ++ modeString) + , arg =<< getInput + , arg outPath ] + where + modeString = case mode of + Html -> "html" + Latex -> "latex" + Man -> "man" diff --git a/hadrian/src/Hadrian/Builder/Tar.hs b/hadrian/src/Hadrian/Builder/Tar.hs new file mode 100644 index 0000000000..75cf725b4b --- /dev/null +++ b/hadrian/src/Hadrian/Builder/Tar.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Builder.Tar +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Support for invoking the archiving utility @tar@. +----------------------------------------------------------------------------- +module Hadrian.Builder.Tar (TarMode (..), args) where + +import Development.Shake +import Development.Shake.Classes +import GHC.Generics +import Hadrian.Expression + +-- | Tar can be used to 'Create' an archive or 'Extract' from it. +data TarMode = Create | Extract deriving (Eq, Generic, Show) + +instance Binary TarMode +instance Hashable TarMode +instance NFData TarMode + + +-- | Default command line arguments for invoking the archiving utility @tar@. +args :: (ShakeValue c, ShakeValue b) => TarMode -> Args c b +args Create = mconcat + [ arg "-c" + , output "//*.gz" ? arg "--gzip" + , output "//*.bz2" ? arg "--bzip2" + , output "//*.xz" ? arg "--xz" + , arg "-f", arg =<< getOutput + , getInputs ] +args Extract = mconcat + [ arg "-x" + , input "*.gz" ? arg "--gzip" + , input "*.bz2" ? arg "--bzip2" + , input "*.xz" ? arg "--xz" + , arg "-f", arg =<< getInput + , arg "-C", arg =<< getOutput ] diff --git a/hadrian/src/Hadrian/Expression.hs b/hadrian/src/Hadrian/Expression.hs new file mode 100644 index 0000000000..53c86de68b --- /dev/null +++ b/hadrian/src/Hadrian/Expression.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} +module Hadrian.Expression ( + -- * Expressions + Expr, Predicate, Args, + + -- ** Construction and modification + expr, exprIO, arg, remove, + + -- ** Predicates + (?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand, + + -- ** Evaluation + interpret, interpretInContext, + + -- * Convenient accessors + getBuildRoot, getContext, getBuilder, getOutputs, getInputs, getInput, getOutput + ) where + +import Control.Monad.Extra +import Control.Monad.Trans +import Control.Monad.Trans.Reader +import Development.Shake +import Development.Shake.Classes + +import qualified Hadrian.Target as Target +import Hadrian.Target (Target, target) +import Hadrian.Utilities + +-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@ +-- and can read parameters of the current build 'Target' @c b@. +newtype Expr c b a = Expr (ReaderT (Target c b) Action a) + deriving (Applicative, Functor, Monad) + +instance Semigroup a => Semigroup (Expr c b a) where + Expr x <> Expr y = Expr $ (<>) <$> x <*> y + +-- TODO: The 'Semigroup a' constraint will at some point become redundant. +instance (Semigroup a, Monoid a) => Monoid (Expr c b a) where + mempty = pure mempty + mappend = (<>) + +-- | Expressions that compute a Boolean value. +type Predicate c b = Expr c b Bool + +-- | Expressions that compute lists of arguments to be passed to builders. +type Args c b = Expr c b [String] + +-- | Lift actions independent from the current build 'Target' into the 'Expr' +-- monad. +expr :: Action a -> Expr c b a +expr = Expr . lift + +-- | Lift IO computations independent from the current build 'Target' into the +-- 'Expr' monad. +exprIO :: IO a -> Expr c b a +exprIO = Expr . liftIO + +-- | Remove given elements from a list expression. +remove :: Eq a => [a] -> Expr c b [a] -> Expr c b [a] +remove xs e = filter (`notElem` xs) <$> e + +-- | Add a single argument to 'Args'. +arg :: String -> Args c b +arg = pure . pure + +-- | Values that can be converted to a 'Predicate'. +class ToPredicate p c b where + toPredicate :: p -> Predicate c b + +infixr 3 ? + +-- | Apply a predicate to an expression. +(?) :: (Monoid a, ToPredicate p c b) => p -> Expr c b a -> Expr c b a +p ? e = do + bool <- toPredicate p + if bool then e else mempty + +instance ToPredicate Bool c b where + toPredicate = pure + +instance ToPredicate p c b => ToPredicate (Action p) c b where + toPredicate = toPredicate . expr + +instance (c ~ c', b ~ b', ToPredicate p c' b') => ToPredicate (Expr c b p) c' b' where + toPredicate p = toPredicate =<< p + +-- | Interpret a given expression according to the given 'Target'. +interpret :: Target c b -> Expr c b a -> Action a +interpret target (Expr e) = runReaderT e target + +-- | Interpret a given expression by looking only at the given 'Context'. +interpretInContext :: c -> Expr c b a -> Action a +interpretInContext c = interpret $ target c + (error "contextOnlyTarget: builder not set") + (error "contextOnlyTarget: inputs not set" ) + (error "contextOnlyTarget: outputs not set") + +-- | Get the directory of build results. +getBuildRoot :: Expr c b FilePath +getBuildRoot = expr buildRoot + +-- | Get the current build 'Context'. +getContext :: Expr c b c +getContext = Expr $ asks Target.context + +-- | Get the 'Builder' for the current 'Target'. +getBuilder :: Expr c b b +getBuilder = Expr $ asks Target.builder + +-- | Get the input files of the current 'Target'. +getInputs :: Expr c b [FilePath] +getInputs = Expr $ asks Target.inputs + +-- | Run 'getInputs' and check that the result contains one input file only. +getInput :: (Show b, Show c) => Expr c b FilePath +getInput = Expr $ do + target <- ask + fromSingleton ("Exactly one input file expected in " ++ show target) <$> + asks Target.inputs + +-- | Get the files produced by the current 'Target'. +getOutputs :: Expr c b [FilePath] +getOutputs = Expr $ asks Target.outputs + +-- | Run 'getOutputs' and check that the result contains one output file only. +getOutput :: (Show b, Show c) => Expr c b FilePath +getOutput = Expr $ do + target <- ask + fromSingleton ("Exactly one output file expected in " ++ show target) <$> + asks Target.outputs + +-- | Does any of the input files match a given pattern? +input :: FilePattern -> Predicate c b +input f = any (f ?==) <$> getInputs + +-- | Does any of the input files match any of the given patterns? +inputs :: [FilePattern] -> Predicate c b +inputs = anyM input + +-- | Does any of the output files match a given pattern? +output :: FilePattern -> Predicate c b +output f = any (f ?==) <$> getOutputs + +-- | Does any of the output files match any of the given patterns? +outputs :: [FilePattern] -> Predicate c b +outputs = anyM output + +newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b } + deriving Typeable + +verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b +verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False) diff --git a/hadrian/src/Hadrian/Haskell/Cabal.hs b/hadrian/src/Hadrian/Haskell/Cabal.hs new file mode 100644 index 0000000000..327e6a0618 --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Cabal.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Haskell.Cabal +-- Copyright : (c) Andrey Mokhov 2014-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Basic functionality for extracting Haskell package metadata stored in +-- Cabal files. +----------------------------------------------------------------------------- +module Hadrian.Haskell.Cabal ( + pkgVersion, pkgIdentifier, pkgSynopsis, pkgDescription, pkgDependencies, + pkgGenericDescription + ) where + +import Development.Shake +import Distribution.PackageDescription (GenericPackageDescription) + +import Hadrian.Haskell.Cabal.Type +import Hadrian.Oracles.Cabal +import Hadrian.Package + +-- | Read a Cabal file and return the package version. The Cabal file is tracked. +pkgVersion :: Package -> Action String +pkgVersion = fmap version . readPackageData + +-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@. +-- The Cabal file is tracked. +pkgIdentifier :: Package -> Action String +pkgIdentifier package = do + cabal <- readPackageData package + return $ if null (version cabal) + then name cabal + else name cabal ++ "-" ++ version cabal + +-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked. +pkgSynopsis :: Package -> Action String +pkgSynopsis = fmap synopsis . readPackageData + +-- | Read a Cabal file and return the package description. The Cabal file is +-- tracked. +pkgDescription :: Package -> Action String +pkgDescription = fmap description . readPackageData + +-- | Read a Cabal file and return the sorted list of the package dependencies. +-- The current version does not take care of Cabal conditionals and therefore +-- returns a crude overapproximation of actual dependencies. The Cabal file is +-- tracked. +pkgDependencies :: Package -> Action [PackageName] +pkgDependencies = fmap (map pkgName . packageDependencies) . readPackageData + +-- | Read a Cabal file and return the 'GenericPackageDescription'. The Cabal +-- file is tracked. +pkgGenericDescription :: Package -> Action GenericPackageDescription +pkgGenericDescription = fmap genericPackageDescription . readPackageData diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs new file mode 100644 index 0000000000..e0edb78731 --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs @@ -0,0 +1,293 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Haskell.Cabal.Parse +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Extracting Haskell package metadata stored in Cabal files. +----------------------------------------------------------------------------- +module Hadrian.Haskell.Cabal.Parse ( + ContextData (..), parsePackageData, resolveContextData, parseCabalPkgId, + configurePackage, copyPackage, registerPackage + ) where + +import Data.Bifunctor +import Data.List.Extra +import Development.Shake +import qualified Distribution.ModuleName as C +import qualified Distribution.Package as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Configuration as C +import qualified Distribution.PackageDescription.Parsec as C +import qualified Distribution.Simple.Compiler as C +import qualified Distribution.Simple.Program.Db as C +import qualified Distribution.Simple as C +import qualified Distribution.Simple.Program.Builtin as C +import qualified Distribution.Simple.Utils as C +import qualified Distribution.Simple.Program.Types as C +import qualified Distribution.Simple.Configure as C (getPersistBuildConfig) +import qualified Distribution.Simple.Build as C +import qualified Distribution.Types.ComponentRequestedSpec as C +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.Simple.PackageIndex as C +import qualified Distribution.Text as C +import qualified Distribution.Types.LocalBuildInfo as C +import qualified Distribution.Types.CondTree as C +import qualified Distribution.Types.MungedPackageId as C +import qualified Distribution.Verbosity as C +import Hadrian.Expression +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type +import Hadrian.Oracles.Cabal +import Hadrian.Target + +import Base +import Builder +import Context +import Flavour +import Packages +import Settings + +-- | Parse the Cabal file of a given 'Package'. This operation is cached by the +-- "Hadrian.Oracles.TextFile.readPackageData" oracle. +parsePackageData :: Package -> Action PackageData +parsePackageData pkg = do + gpd <- liftIO $ C.readGenericPackageDescription C.verbose (pkgCabalFile pkg) + let pd = C.packageDescription gpd + pkgId = C.package pd + name = C.unPackageName (C.pkgName pkgId) + version = C.display (C.pkgVersion pkgId) + libDeps = collectDeps (C.condLibrary gpd) + exeDeps = map (collectDeps . Just . snd) (C.condExecutables gpd) + allDeps = concat (libDeps : exeDeps) + sorted = sort [ C.unPackageName p | C.Dependency p _ <- allDeps ] + deps = nubOrd sorted \\ [name] + depPkgs = catMaybes $ map findPackageByName deps + return $ PackageData name version (C.synopsis pd) (C.description pd) depPkgs gpd + where + -- Collect an overapproximation of dependencies by ignoring conditionals + collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency] + collectDeps Nothing = [] + collectDeps (Just (C.CondNode _ deps ifs)) = deps ++ concatMap f ifs + where + f (C.CondBranch _ t mt) = collectDeps (Just t) ++ collectDeps mt + +-- | Parse the package identifier from a Cabal file. +parseCabalPkgId :: FilePath -> IO String +parseCabalPkgId file = C.display . C.package . C.packageDescription <$> C.readGenericPackageDescription C.silent file + +biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName], Maybe (C.ModuleName, String)) +biModules pd = go [ comp | comp@(bi,_,_) <- + (map libBiModules . maybeToList $ C.library pd) ++ + (map exeBiModules $ C.executables pd) + , C.buildable bi ] + where + libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib, Nothing) + exeBiModules exe = (C.buildInfo exe, + -- If "main-is: ..." is not a .hs or .lhs file, do not + -- inject "Main" into the modules. This does not respect + -- "-main-is" ghc-arguments! See Cabal's + -- Distribution.Simple.GHC for the glory details. + if takeExtension (C.modulePath exe) `elem` [".hs", ".lhs"] + then C.main : C.exeModules exe + -- The module `Main` still need to be kept in `modules` of PD. + else C.exeModules exe, + Just (C.main, C.modulePath exe)) + go [] = error "No buildable component found." + go [x] = x + go _ = error "Cannot handle more than one buildinfo yet." + +-- TODO: Track command line arguments and package configuration flags. +-- | Configure a package using the Cabal library by collecting all the command +-- line arguments (to be passed to the setup script) and package configuration +-- flags. The function 'need's package database entries for the dependencies of +-- the package the 'Context' points to. +configurePackage :: Context -> Action () +configurePackage context@Context {..} = do + putLoud $ "| Configure package " ++ quote (pkgName package) + + gpd <- pkgGenericDescription package + depPkgs <- packageDependencies <$> readPackageData package + + -- Stage packages are those we have in this stage. + stagePkgs <- stagePackages stage + -- We'll need those packages in our package database. + deps <- sequence [ pkgConfFile (context { package = pkg }) + | pkg <- depPkgs, pkg `elem` stagePkgs ] + need deps + + -- Figure out what hooks we need. + hooks <- case C.buildType (C.flattenPackageDescription gpd) of + C.Configure -> pure C.autoconfUserHooks + -- The 'time' package has a 'C.Custom' Setup.hs, but it's actually + -- 'C.Configure' plus a @./Setup test@ hook. However, Cabal is also + -- 'C.Custom', but doesn't have a configure script. + C.Custom -> do + configureExists <- doesFileExist $ + replaceFileName (pkgCabalFile package) "configure" + pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks + -- Not quite right, but good enough for us: + _ | package == rts -> + -- Don't try to do post configuration validation for 'rts'. This + -- will simply not work, due to the @ld-options@ and @Stg.h@. + pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () } + | otherwise -> pure C.simpleUserHooks + + -- Compute the list of flags, and the Cabal configurartion arguments + flavourArgs <- args <$> flavour + flagList <- interpret (target context (Cabal Flags stage) [] []) flavourArgs + argList <- interpret (target context (Cabal Setup stage) [] []) flavourArgs + verbosity <- getVerbosity + let v = if verbosity >= Loud then "-v3" else "-v0" + liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd + (argList ++ ["--flags=" ++ unwords flagList, v]) + +-- | Copy the 'Package' of a given 'Context' into the package database +-- corresponding to the 'Stage' of the 'Context'. +copyPackage :: Context -> Action () +copyPackage context@Context {..} = do + putLoud $ "| Copy package " ++ quote (pkgName package) + gpd <- pkgGenericDescription package + ctxPath <- Context.contextPath context + pkgDbPath <- packageDbPath stage + verbosity <- getVerbosity + let v = if verbosity >= Loud then "-v3" else "-v0" + liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd + [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ] + +-- | Register the 'Package' of a given 'Context' into the package database. +registerPackage :: Context -> Action () +registerPackage context@Context {..} = do + putLoud $ "| Register package " ++ quote (pkgName package) + ctxPath <- Context.contextPath context + gpd <- pkgGenericDescription package + verbosity <- getVerbosity + let v = if verbosity >= Loud then "-v3" else "-v0" + liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd + [ "register", "--builddir", ctxPath, v ] + +-- | Parse the 'ContextData' of a given 'Context'. +resolveContextData :: Context -> Action ContextData +resolveContextData context@Context {..} = do + -- TODO: This is conceptually wrong! + -- We should use the gpd, the flagAssignment and compiler, hostPlatform, and + -- other information from the lbi. And then compute the finalised PD (flags, + -- satisfiable dependencies, platform, compiler info, deps, gpd). + -- + -- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd + -- + -- However when using the new-build path's this might change. + + -- Read the package description from the Cabal file + gpd <- genericPackageDescription <$> readPackageData package + + -- Configure the package with the GHC for this stage + (compiler, platform) <- configurePackageGHC package stage + + flagList <- interpret (target context (Cabal Flags stage) [] []) =<< args <$> flavour + let flags = foldr addFlag mempty flagList + where + addFlag :: String -> C.FlagAssignment -> C.FlagAssignment + addFlag ('-':name) = C.insertFlagAssignment (C.mkFlagName name) False + addFlag ('+':name) = C.insertFlagAssignment (C.mkFlagName name) True + addFlag name = C.insertFlagAssignment (C.mkFlagName name) True + + let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec + (const True) platform (C.compilerInfo compiler) [] gpd + + cPath <- Context.contextPath context + need [cPath -/- "setup-config"] + + lbi <- liftIO $ C.getPersistBuildConfig cPath + + -- TODO: Move this into its own rule for @build/autogen/cabal_macros.h@, and + -- @build/autogen/Path_*.hs@ and 'need' these files here. + -- Create the @cabal_macros.h@, ... + -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path + -- from the local build info @lbi@. + pdi <- liftIO $ getHookedBuildInfo (pkgPath package) + let pd' = C.updatePackageDescription pdi pd + lbi' = lbi { C.localPkgDescr = pd' } + liftIO $ C.initialBuildSteps cPath pd' lbi' C.silent + + -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations + -- See: https://github.com/snowleopard/hadrian/issues/548 + let extDeps = C.externalPackageDeps lbi' + deps = map (C.display . snd) extDeps + depDirect = map (fromMaybe (error "resolveContextData: depDirect failed") + . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps + depIds = map (C.display . Installed.installedUnitId) depDirect + Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi') + depPkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi')) + forDeps f = concatMap f depPkgs + + -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs + packageHacks = case C.compilerFlavor (C.compiler lbi') of + C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage + _ -> id + + -- TODO: Get rid of this hack. + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the "-u" flags in @ldOptions@ of the @rts@ package mean linking fails + -- on OS X (its @ld@ is a tad stricter than GNU @ld@). Thus we remove + -- @ldOptions@ for the @rts@ package. With one exception (see below). + hackRtsPackage index | null (C.allPackages index) = index + -- ^ do not hack the empty index + hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of + [(_, [rts])] -> C.insert rts { + Installed.ldOptions = [], + Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) + (Installed.libraryDirs rts)} index + -- GHC <= 6.12 had @$topdir/gcc-lib@ in their @library-dirs@ for the + -- 'rts' package, which causes problems when we try to use the + -- in-tree @mingw@, due to accidentally picking up the incompatible + -- libraries there. So we filter out @gcc-lib@ from the RTS's + -- @library-dirs@ here. + _ -> error "No (or multiple) GHC rts package is registered!" + + (buildInfo, modules, mainIs) = biModules pd' + + in return $ ContextData + { dependencies = deps + , componentId = C.localCompatPackageKey lbi' + , mainIs = fmap (first C.display) mainIs + , modules = map C.display modules + , otherModules = map C.display $ C.otherModules buildInfo + , srcDirs = C.hsSourceDirs buildInfo + , depIds = depIds + , depNames = map (C.display . C.mungedName . snd) extDeps + , includeDirs = C.includeDirs buildInfo + , includes = C.includes buildInfo + , installIncludes = C.installIncludes buildInfo + , extraLibs = C.extraLibs buildInfo + , extraLibDirs = C.extraLibDirs buildInfo + , asmSrcs = C.asmSources buildInfo + , cSrcs = C.cSources buildInfo + , cmmSrcs = C.cmmSources buildInfo + , hcOpts = C.programDefaultArgs ghcProg + ++ C.hcOptions C.GHC buildInfo + ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage buildInfo) + ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions buildInfo) + ++ C.programOverrideArgs ghcProg + , asmOpts = C.asmOptions buildInfo + , ccOpts = C.ccOptions buildInfo + , cmmOpts = C.cmmOptions buildInfo + , cppOpts = C.cppOptions buildInfo + , ldOpts = C.ldOptions buildInfo + , depIncludeDirs = forDeps Installed.includeDirs + , depCcOpts = forDeps Installed.ccOptions + , depLdOpts = forDeps Installed.ldOptions + , buildGhciLib = C.withGHCiLib lbi' } + +getHookedBuildInfo :: FilePath -> IO C.HookedBuildInfo +getHookedBuildInfo baseDir = do + -- TODO: We should probably better generate this in the build directory, + -- rather than in the base directory? However, @configure@ is run in the + -- base directory. + maybeInfoFile <- C.findHookedPackageDesc baseDir + case maybeInfoFile of + Nothing -> return C.emptyHookedBuildInfo + Just infoFile -> C.readHookedBuildInfo C.silent infoFile diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs new file mode 100644 index 0000000000..dd6e4bdcc6 --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Haskell.Cabal.Type +-- Copyright : (c) Andrey Mokhov 2014-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Data types for storing basic Haskell package metadata, such as package name, +-- version and dependencies, extracted from a Cabal file. +----------------------------------------------------------------------------- +module Hadrian.Haskell.Cabal.Type where + +import Development.Shake.Classes +import Distribution.PackageDescription +import GHC.Generics + +import Hadrian.Package + +-- | Haskell package metadata extracted from a Cabal file without performing +-- the resolution of package configuration flags and associated conditionals, +-- which are build context specific. Note that 'packageDependencies' is an +-- overappoximation of actual package dependencies; for example, both @unix@ and +-- @win32@ packages may be included even if only one of them is required on the +-- target OS. See 'ContextData' for metadata obtained after resolving package +-- configuration flags and conditionals according to the current build context. +data PackageData = PackageData + { name :: PackageName + , version :: String + , synopsis :: String + , description :: String + , packageDependencies :: [Package] + , genericPackageDescription :: GenericPackageDescription + } deriving (Eq, Generic, Show, Typeable) + +-- | Haskell package metadata obtained after resolving package configuration +-- flags and associated conditionals according to the current build context. +-- See 'PackageData' for metadata that can be obtained without resolving package +-- configuration flags and conditionals. +data ContextData = ContextData + { dependencies :: [PackageName] + , componentId :: String + , mainIs :: Maybe (String, FilePath) -- ("Main", filepath) + , modules :: [String] + , otherModules :: [String] + , srcDirs :: [String] + , depIds :: [String] + , depNames :: [String] + , includeDirs :: [String] + , includes :: [String] + , installIncludes :: [String] + , extraLibs :: [String] + , extraLibDirs :: [String] + , asmSrcs :: [String] + , cSrcs :: [String] + , cmmSrcs :: [String] + , hcOpts :: [String] + , asmOpts :: [String] + , ccOpts :: [String] + , cmmOpts :: [String] + , cppOpts :: [String] + , ldOpts :: [String] + , depIncludeDirs :: [String] + , depCcOpts :: [String] + , depLdOpts :: [String] + , buildGhciLib :: Bool + } deriving (Eq, Generic, Show, Typeable) + +instance Binary PackageData +instance Hashable PackageData where hashWithSalt salt = hashWithSalt salt . show +instance NFData PackageData + +instance Binary ContextData +instance Hashable ContextData +instance NFData ContextData diff --git a/hadrian/src/Hadrian/Oracles/ArgsHash.hs b/hadrian/src/Hadrian/Oracles/ArgsHash.hs new file mode 100644 index 0000000000..bae2fdbd80 --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/ArgsHash.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeFamilies #-} +module Hadrian.Oracles.ArgsHash ( + TrackArgument, trackAllArguments, trackArgsHash, argsHashOracle + ) where + +import Control.Monad +import Development.Shake +import Development.Shake.Classes + +import Hadrian.Expression hiding (inputs, outputs) +import Hadrian.Target + +-- | 'TrackArgument' is used to specify the arguments that should be tracked by +-- the @ArgsHash@ oracle. The safest option is to track all arguments, but some +-- arguments, such as @-jN@, do not change the build results, hence there is no +-- need to initiate unnecessary rebuild if they are added to or removed from a +-- command line. If all arguments should be tracked, use 'trackAllArguments'. +type TrackArgument c b = Target c b -> String -> Bool + +-- | Returns 'True' for all targets and arguments, hence can be used a safe +-- default for 'argsHashOracle'. +trackAllArguments :: TrackArgument c b +trackAllArguments _ _ = True + +-- | Given a 'Target' this 'Action' determines the corresponding argument list +-- and computes its hash. The resulting value is tracked in a Shake oracle, +-- hence initiating rebuilds when the hash changes (a hash change indicates +-- changes in the build command for the given target). +-- Note: for efficiency we replace the list of input files with its hash to +-- avoid storing long lists of source files passed to some builders (e.g. ar) +-- in the Shake database. This optimisation is normally harmless, because +-- argument list constructors are assumed not to examine target sources, but +-- only append them to argument lists where appropriate. +trackArgsHash :: (ShakeValue c, ShakeValue b) => Target c b -> Action () +trackArgsHash t = do + let hashedInputs = [ show $ hash (inputs t) ] + hashedTarget = target (context t) (builder t) hashedInputs (outputs t) + void (askOracle $ ArgsHash hashedTarget :: Action Int) + +newtype ArgsHash c b = ArgsHash (Target c b) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult (ArgsHash c b) = Int + +-- | This oracle stores per-target argument list hashes in the Shake database, +-- allowing the user to track them between builds using 'trackArgsHash' queries. +argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules () +argsHashOracle trackArgument args = void $ + addOracle $ \(ArgsHash target) -> do + argList <- interpret target args + let trackedArgList = filter (trackArgument target) argList + return $ hash trackedArgList diff --git a/hadrian/src/Hadrian/Oracles/Cabal.hs b/hadrian/src/Hadrian/Oracles/Cabal.hs new file mode 100644 index 0000000000..4c52162729 --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/Cabal.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Oracles.Cabal +-- Copyright : (c) Andrey Mokhov 2014-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- This module defines oracles for reading and parsing Cabal files, as well as +-- for configuring Haskell packages. +----------------------------------------------------------------------------- +module Hadrian.Oracles.Cabal ( + readPackageData, readContextData, configurePackageGHC + ) where + +import Development.Shake +import Distribution.Simple (Compiler) +import Distribution.System (Platform) + +import Context.Type +import Hadrian.Haskell.Cabal.Type +import Hadrian.Oracles.Cabal.Type +import Hadrian.Package +import Stage + +-- | Read and parse a Cabal file, caching and tracking the result. +readPackageData :: Package -> Action PackageData +readPackageData = askOracle . PackageDataKey + +-- | Read and parse a Cabal file recording the obtained 'ContextData', caching +-- and tracking the result. Note that unlike 'readPackageData' this function +-- resolves all Cabal configuration flags and associated conditionals. +readContextData :: Context -> Action ContextData +readContextData = askOracle . ContextDataKey + +-- | Configure a 'Package' using the GHC corresponding to a given 'Stage', +-- caching and tracking the result. +configurePackageGHC :: Package -> Stage -> Action (Compiler, Platform) +configurePackageGHC pkg stage = do + PackageConfiguration res <- askOracle $ PackageConfigurationKey (pkg, stage) + return res diff --git a/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs b/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs new file mode 100644 index 0000000000..dcda3704a8 --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Oracles.Cabal.Rules +-- Copyright : (c) Andrey Mokhov 2014-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- This module defines Shake rules corresponing to the /Cabal oracle/; see +-- the module "Hadrian.Oracles.Cabal" for various supported queries. +----------------------------------------------------------------------------- +module Hadrian.Oracles.Cabal.Rules where + +import Control.Monad +import Data.Maybe +import Development.Shake +import Distribution.Simple.GHC +import Distribution.Simple.Program.Db +import Distribution.Verbosity + +import Builder +import Context.Type +import Hadrian.Haskell.Cabal.Parse +import Hadrian.Oracles.Cabal.Type +import Hadrian.Package +import Hadrian.Utilities + +-- | These oracle rules are used to cache and track answers to the following +-- queries, which are implemented via the Cabal library: +-- +-- 1) 'Hadrian.Oracles.Cabal.readPackageData' that reads Cabal package data. +-- +-- 2) 'Hadrian.Oracles.Cabal.readContextData' that reads 'Context'-dependent +-- Cabal package data. +-- +-- 3) 'Hadrian.Oracles.Cabal.configurePackageGHC' that configures a package. +cabalOracle :: Rules () +cabalOracle = do + void $ addOracleCache $ \(PackageDataKey package) -> do + let file = pkgCabalFile package + need [file] + putLoud $ "| PackageData oracle: parsing " ++ quote file ++ "..." + parsePackageData package + + void $ addOracleCache $ \(ContextDataKey context@Context {..}) -> do + putLoud $ "| ContextData oracle: resolving data for " + ++ quote (pkgName package) ++ " (" ++ show stage + ++ ", " ++ show way ++ ")..." + resolveContextData context + + void $ addOracleCache $ \(PackageConfigurationKey (pkg, stage)) -> do + putLoud $ "| PackageConfiguration oracle: configuring " + ++ quote (pkgName pkg) ++ " (" ++ show stage ++ ")..." + -- Configure the package with the GHC corresponding to the given stage + hcPath <- builderPath (Ghc CompileHs stage) + (compiler, maybePlatform, _pkgdb) <- liftIO $ + configure silent (Just hcPath) Nothing emptyProgramDb + let platform = fromMaybe (error msg) maybePlatform + msg = "PackageConfiguration oracle: cannot detect platform" + return $ PackageConfiguration (compiler, platform) diff --git a/hadrian/src/Hadrian/Oracles/Cabal/Type.hs b/hadrian/src/Hadrian/Oracles/Cabal/Type.hs new file mode 100644 index 0000000000..d1b09472ed --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/Cabal/Type.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Oracles.Cabal.Type +-- Copyright : (c) Andrey Mokhov 2014-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- This module defines the types of keys used by the /Cabal oracles/. See the +-- module "Hadrian.Oracles.Cabal" for supported Cabal oracle queries, and the +-- module "Hadrian.Oracles.Cabal.Rules" for the corresponing Shake rules. +----------------------------------------------------------------------------- +module Hadrian.Oracles.Cabal.Type where + +import Development.Shake +import Development.Shake.Classes +import qualified Distribution.Simple as C +import qualified Distribution.System as C + +import Context.Type +import Hadrian.Haskell.Cabal.Type +import Hadrian.Package +import Stage + +-- | This type of oracle key is used by 'Hadrian.Oracles.Cabal.readPackageData' +-- to cache reading and parsing of 'Hadrian.Haskell.Cabal.Type.PackageData'. +newtype PackageDataKey = PackageDataKey Package + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult PackageDataKey = PackageData + +-- | This type of oracle key is used by 'Hadrian.Oracles.Cabal.readContextData' +-- to cache reading and parsing of 'Hadrian.Haskell.Cabal.Type.ContextData'. +newtype ContextDataKey = ContextDataKey Context + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult ContextDataKey = ContextData + +-- TODO: Should @PackageConfiguration@ be simply @()@? Presumably the pair +-- @(Compiler, Maybe Platform)@ is fully determined by the current build Stage. +-- | The result of Cabal package configuration produced by the oracle +-- 'Hadrian.Oracles.Cabal.configurePackageGHC'. +newtype PackageConfiguration = PackageConfiguration (C.Compiler, C.Platform) + deriving (Binary, Eq, Show, Typeable) + +instance NFData PackageConfiguration where + rnf (PackageConfiguration (c, p)) = + rnf (C.compilerId c) `seq` + rnf (C.abiTagString $ C.compilerAbiTag c) `seq` + rnf (C.compilerCompat c) `seq` + rnf (C.compilerLanguages c) `seq` + rnf (C.compilerExtensions c) `seq` + rnf (C.compilerProperties c) `seq` + rnf p + +instance Hashable PackageConfiguration where + hashWithSalt _ = hash . show + +-- | This type of oracle key is used by 'Hadrian.Oracles.Cabal.configurePackageGHC' +-- to cache configuration of a Cabal package. +newtype PackageConfigurationKey = PackageConfigurationKey (Package, Stage) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult PackageConfigurationKey = PackageConfiguration diff --git a/hadrian/src/Hadrian/Oracles/DirectoryContents.hs b/hadrian/src/Hadrian/Oracles/DirectoryContents.hs new file mode 100644 index 0000000000..f302af9da0 --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/DirectoryContents.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} +module Hadrian.Oracles.DirectoryContents ( + directoryContents, copyDirectoryContents, directoryContentsOracle, copyDirectoryContentsUntracked, + Match (..), matches, matchAll + ) where + +import Control.Monad +import Development.Shake +import Development.Shake.Classes +import Development.Shake.FilePath +import GHC.Generics + +import Hadrian.Utilities + +import qualified System.Directory.Extra as IO + +data Match = Test FilePattern | Not Match | And [Match] | Or [Match] + deriving (Generic, Eq, Show, Typeable) + +instance Binary Match +instance Hashable Match +instance NFData Match + +-- | A 'Match' expression that always evaluates to 'True' (i.e. always matches). +matchAll :: Match +matchAll = And [] + +-- | Check if a file name matches a given 'Match' expression. +matches :: Match -> FilePath -> Bool +matches (Test p) f = p ?== f +matches (Not m) f = not $ matches m f +matches (And ms) f = all (`matches` f) ms +matches (Or ms) f = any (`matches` f) ms + +-- | Given a 'Match' expression and a directory, recursively traverse it and all +-- its subdirectories to find and return all matching contents. +directoryContents :: Match -> FilePath -> Action [FilePath] +directoryContents expr dir = askOracle $ DirectoryContents (expr, dir) + +-- | Copy the contents of the source directory that matches a given 'Match' +-- expression into the target directory. The copied contents is tracked. +copyDirectoryContents :: Match -> FilePath -> FilePath -> Action () +copyDirectoryContents expr source target = do + putProgressInfo =<< renderAction "Copy directory contents" source target + let cp file = copyFile file $ target -/- makeRelative source file + mapM_ cp =<< directoryContents expr source + +-- | Copy the contents of the source directory that matches a given 'Match' +-- expression into the target directory. The copied contents is untracked. +copyDirectoryContentsUntracked :: Match -> FilePath -> FilePath -> Action () +copyDirectoryContentsUntracked expr source target = do + putProgressInfo =<< renderAction "Copy directory contents (untracked)" source target + let cp file = copyFileUntracked file $ target -/- makeRelative source file + mapM_ cp =<< directoryContents expr source + +newtype DirectoryContents = DirectoryContents (Match, FilePath) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult DirectoryContents = [FilePath] + +-- | This oracle answers 'directoryContents' queries and tracks the results. +directoryContentsOracle :: Rules () +directoryContentsOracle = void $ + addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath . + filter (matches expr) <$> IO.listFilesInside (return . matches expr) dir diff --git a/hadrian/src/Hadrian/Oracles/Path.hs b/hadrian/src/Hadrian/Oracles/Path.hs new file mode 100644 index 0000000000..ab771a485f --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/Path.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TypeFamilies #-} +module Hadrian.Oracles.Path ( + lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle + ) where + +import Control.Monad +import Data.Maybe +import Data.Char +import Data.List.Extra +import Development.Shake +import Development.Shake.Classes +import Development.Shake.FilePath +import System.Directory +import System.Info.Extra + +import Hadrian.Utilities + +-- | Lookup a specified 'FilePath' in the system @PATH@. +lookupInPath :: FilePath -> Action FilePath +lookupInPath name + | name == takeFileName name = askOracle $ LookupInPath name + | otherwise = return name + +-- | Lookup the path to the @bash@ interpreter. +bashPath :: Action FilePath +bashPath = lookupInPath "bash" + +-- | Fix an absolute path on Windows: +-- * "/c/" => "C:/" +-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe" +fixAbsolutePathOnWindows :: FilePath -> Action FilePath +fixAbsolutePathOnWindows path = + if isWindows + then do + let (dir, file) = splitFileName path + winDir <- askOracle $ WindowsPath dir + return $ winDir -/- file + else + return path + +newtype LookupInPath = LookupInPath String + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult LookupInPath = String + +newtype WindowsPath = WindowsPath FilePath + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult WindowsPath = String + +-- | Oracles for looking up paths. These are slow and require caching. +pathOracle :: Rules () +pathOracle = do + void $ addOracleCache $ \(WindowsPath path) -> do + Stdout out <- quietly $ cmd ["cygpath", "-m", path] + let windowsPath = unifyPath $ dropWhileEnd isSpace out + putLoud $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath + return windowsPath + + void $ addOracleCache $ \(LookupInPath name) -> do + let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name + path <- unifyPath . unpack <$> liftIO (findExecutable name) + putLoud $ "| Executable found: " ++ name ++ " => " ++ path + return path diff --git a/hadrian/src/Hadrian/Oracles/TextFile.hs b/hadrian/src/Hadrian/Oracles/TextFile.hs new file mode 100644 index 0000000000..aef553f70d --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/TextFile.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Oracles.TextFile +-- Copyright : (c) Andrey Mokhov 2014-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Read and parse text files, tracking their contents. This oracle can be used +-- to read configuration or package metadata files and cache the parsing. +----------------------------------------------------------------------------- +module Hadrian.Oracles.TextFile ( + lookupValue, lookupValueOrEmpty, lookupValueOrError, lookupValues, + lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle + ) where + +import Control.Monad +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Development.Shake +import Development.Shake.Classes +import Development.Shake.Config + +import Hadrian.Utilities + +-- | Lookup a value in a text file, tracking the result. Each line of the file +-- is expected to have @key = value@ format. +lookupValue :: FilePath -> String -> Action (Maybe String) +lookupValue file key = askOracle $ KeyValue (file, key) + +-- | Like 'lookupValue' but returns the empty string if the key is not found. +lookupValueOrEmpty :: FilePath -> String -> Action String +lookupValueOrEmpty file key = fromMaybe "" <$> lookupValue file key + +-- | Like 'lookupValue' but raises an error if the key is not found. +lookupValueOrError :: FilePath -> String -> Action String +lookupValueOrError file key = fromMaybe (error msg) <$> lookupValue file key + where + msg = "Key " ++ quote key ++ " not found in file " ++ quote file + +-- | Lookup a list of values in a text file, tracking the result. Each line of +-- the file is expected to have @key value1 value2 ...@ format. +lookupValues :: FilePath -> String -> Action (Maybe [String]) +lookupValues file key = askOracle $ KeyValues (file, key) + +-- | Like 'lookupValues' but returns the empty list if the key is not found. +lookupValuesOrEmpty :: FilePath -> String -> Action [String] +lookupValuesOrEmpty file key = fromMaybe [] <$> lookupValues file key + +-- | Like 'lookupValues' but raises an error if the key is not found. +lookupValuesOrError :: FilePath -> String -> Action [String] +lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key + where + msg = "Key " ++ quote key ++ " not found in file " ++ quote file + +-- | The 'Action' @lookupDependencies depFile file@ looks up dependencies of a +-- @file@ in a (typically generated) dependency file @depFile@. The action +-- returns a pair @(source, files)@, such that the @file@ can be produced by +-- compiling @source@, which in turn also depends on a number of other @files@. +lookupDependencies :: FilePath -> FilePath -> Action (FilePath, [FilePath]) +lookupDependencies depFile file = do + deps <- lookupValues depFile file + case deps of + Nothing -> error $ "No dependencies found for file " ++ quote file + Just [] -> error $ "No source file found for file " ++ quote file + Just (source : files) -> return (source, files) + +newtype KeyValue = KeyValue (FilePath, String) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult KeyValue = Maybe String + +newtype KeyValues = KeyValues (FilePath, String) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult KeyValues = Maybe [String] + +-- | These oracle rules are used to cache and track answers to the following +-- queries, which are implemented by parsing text files: +-- +-- 1) Looking up key-value pairs formatted as @key = value1 value2 ...@ that +-- are often used in text configuration files. See functions 'lookupValue', +-- 'lookupValueOrEmpty', 'lookupValueOrError', 'lookupValues', +-- 'lookupValuesOrEmpty' and 'lookupValuesOrError'. +-- +-- 2) Parsing Makefile dependecy files generated by commands like @gcc -MM@: +-- see 'lookupDependencies'. +textFileOracle :: Rules () +textFileOracle = do + kv <- newCache $ \file -> do + need [file] + putLoud $ "| KeyValue oracle: reading " ++ quote file ++ "..." + liftIO $ readConfigFile file + void $ addOracleCache $ \(KeyValue (file, key)) -> Map.lookup key <$> kv file + + kvs <- newCache $ \file -> do + need [file] + putLoud $ "| KeyValues oracle: reading " ++ quote file ++ "..." + contents <- map words <$> readFileLines file + return $ Map.fromList [ (key, values) | (key:values) <- contents ] + void $ addOracleCache $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file diff --git a/hadrian/src/Hadrian/Package.hs b/hadrian/src/Hadrian/Package.hs new file mode 100644 index 0000000000..6bc31d7c58 --- /dev/null +++ b/hadrian/src/Hadrian/Package.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Package +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- A /package/ is a collection of files. We currently only support C and Haskell +-- packages and treat a package as either a library or a program. The latter is +-- a gross oversimplification as, for example, Haskell packages can be both. +-- This works for now, but should be improved in future. +----------------------------------------------------------------------------- +module Hadrian.Package ( + -- * Data types + Package (..), PackageName, PackageType, + + -- * Construction and properties + library, program, dummyPackage, isLibrary, isProgram, + + -- * Package directory structure + pkgCabalFile + ) where + +import Development.Shake.Classes +import Development.Shake.FilePath +import GHC.Generics + +import Hadrian.Utilities + +-- TODO: Make PackageType more precise. +-- See https://github.com/snowleopard/hadrian/issues/12. +data PackageType = Library | Program deriving (Eq, Generic, Ord, Show) + +type PackageName = String + +-- TODO: Consider turning Package into a GADT indexed with language and type. +data Package = Package { + -- | The package type. 'Library' and 'Program' packages are supported. + pkgType :: PackageType, + -- | The package name. We assume that all packages have different names, + -- hence two packages with the same name are considered equal. + pkgName :: PackageName, + -- | The path to the package source code relative to the root of the build + -- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the + -- @Cabal@ and @ghc-bin@ packages in GHC. + pkgPath :: FilePath + } deriving (Eq, Generic, Ord, Show) + +-- | Construct a library package. +library :: PackageName -> FilePath -> Package +library = Package Library + +-- | Construct a program package. +program :: PackageName -> FilePath -> Package +program = Package Program + +-- TODO: Remove this hack. +-- | A dummy package that we never try to build but use when we need a 'Package' +-- to construct a 'Context' but do not need to access the package field. +dummyPackage :: Package +dummyPackage = library "dummy" "dummy/path/" + +-- | Is this a library package? +isLibrary :: Package -> Bool +isLibrary (Package Library _ _) = True +isLibrary _ = False + +-- | Is this a program package? +isProgram :: Package -> Bool +isProgram (Package Program _ _) = True +isProgram _ = False + +-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@. +pkgCabalFile :: Package -> FilePath +pkgCabalFile p = pkgPath p -/- pkgName p <.> "cabal" + +instance Binary PackageType +instance Hashable PackageType +instance NFData PackageType + +instance Binary Package +instance Hashable Package +instance NFData Package
\ No newline at end of file diff --git a/hadrian/src/Hadrian/Target.hs b/hadrian/src/Hadrian/Target.hs new file mode 100644 index 0000000000..88489776c0 --- /dev/null +++ b/hadrian/src/Hadrian/Target.hs @@ -0,0 +1,29 @@ +module Hadrian.Target (Target, target, context, builder, inputs, outputs) where + +import Development.Shake.Classes +import GHC.Generics + +-- | Each invocation of a builder is fully described by a 'Target', which +-- comprises a build context (type variable @c@), a builder (type variable @b@), +-- a list of input files and a list of output files. For example: +-- +-- @ +-- preludeTarget = Target (GHC.Context) (GHC.Builder) +-- { context = Context Stage1 base profiling +-- , builder = Ghc Stage1 +-- , inputs = ["libraries/base/Prelude.hs"] +-- , outputs = ["build/stage1/libraries/base/Prelude.p_o"] } +-- @ +data Target c b = Target + { context :: c -- ^ Current build context + , builder :: b -- ^ Builder to be invoked + , inputs :: [FilePath] -- ^ Input files for the builder + , outputs :: [FilePath] -- ^ Files to be produced + } deriving (Eq, Generic, Show) + +target :: c -> b -> [FilePath] -> [FilePath] -> Target c b +target = Target + +instance (Binary c, Binary b) => Binary (Target c b) +instance (Hashable c, Hashable b) => Hashable (Target c b) +instance (NFData c, NFData b) => NFData (Target c b) diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs new file mode 100644 index 0000000000..88b5bad911 --- /dev/null +++ b/hadrian/src/Hadrian/Utilities.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE TypeFamilies #-} +module Hadrian.Utilities ( + -- * List manipulation + fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize, + + -- * String manipulation + quote, yesNo, parseYesNo, zeroOne, + + -- * FilePath manipulation + unifyPath, (-/-), + + -- * Accessing Shake's type-indexed map + insertExtra, lookupExtra, userSetting, + + -- * Paths + BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, + + -- * File system operations + copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile, + createDirectory, copyDirectory, moveDirectory, removeDirectory, + + -- * Diagnostic info + UseColour (..), Colour (..), ANSIColour (..), putColoured, + BuildProgressColour, mkBuildProgressColour, putBuild, + SuccessColour, mkSuccessColour, putSuccess, + ProgressInfo (..), putProgressInfo, + renderAction, renderActionNoOutput, renderProgram, renderLibrary, renderBox, renderUnicorn, + + -- * Miscellaneous + (<&>), (%%>), cmdLineLengthLimit, + + -- * Useful re-exports + Dynamic, fromDynamic, toDyn, TypeRep, typeOf + ) where + +import Control.Monad.Extra +import Data.Char +import Data.Dynamic (Dynamic, fromDynamic, toDyn) +import Data.HashMap.Strict (HashMap) +import Data.List.Extra +import Data.Maybe +import Data.Typeable (TypeRep, typeOf) +import Development.Shake hiding (Normal) +import Development.Shake.Classes +import Development.Shake.FilePath +import System.Environment (lookupEnv) +import System.Info.Extra + +import qualified Control.Exception.Base as IO +import qualified Data.HashMap.Strict as Map +import qualified System.Directory.Extra as IO +import qualified System.Info.Extra as IO +import qualified System.IO as IO + +-- | Extract a value from a singleton list, or terminate with an error message +-- if the list does not contain exactly one value. +fromSingleton :: String -> [a] -> a +fromSingleton _ [res] = res +fromSingleton msg _ = error msg + +-- | Find and replace all occurrences of a value in a list. +replaceEq :: Eq a => a -> a -> [a] -> [a] +replaceEq from to = map (\cur -> if cur == from then to else cur) + +-- Explicit definition to avoid dependency on Data.List.Ordered +-- | Difference of two ordered lists. +minusOrd :: Ord a => [a] -> [a] -> [a] +minusOrd [] _ = [] +minusOrd xs [] = xs +minusOrd (x:xs) (y:ys) = case compare x y of + LT -> x : minusOrd xs (y:ys) + EQ -> minusOrd xs ys + GT -> minusOrd (x:xs) ys + +-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests +-- | Intersection of two ordered lists by a predicate. +intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a] +intersectOrd cmp = loop + where + loop [] _ = [] + loop _ [] = [] + loop (x:xs) (y:ys) = case cmp x y of + LT -> loop xs (y:ys) + EQ -> x : loop xs (y:ys) + GT -> loop (x:xs) ys + +-- | Lookup all elements of a given sorted list in a given sorted dictionary. +-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has +-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|). +-- +-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3] +-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list +lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b] +lookupAll [] _ = [] +lookupAll (_:xs) [] = Nothing : lookupAll xs [] +lookupAll (x:xs) (y:ys) = case compare x (fst y) of + LT -> Nothing : lookupAll xs (y:ys) + EQ -> Just (snd y) : lookupAll xs (y:ys) + GT -> lookupAll (x:xs) ys + +-- | @chunksOfSize size strings@ splits a given list of strings into chunks not +-- exceeding the given @size@. If that is impossible, it uses singleton chunks. +chunksOfSize :: Int -> [String] -> [[String]] +chunksOfSize n = repeatedly f + where + f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs + +-- | Add single quotes around a string. +quote :: String -> String +quote s = "'" ++ s ++ "'" + +-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string. +yesNo :: Bool -> String +yesNo True = "YES" +yesNo False = "NO" + +-- | Parse a 'Bool' from a @"YES"@ or @"NO"@ string. Returns @Nothing@ in case +-- of a parse failure. +parseYesNo :: String -> Maybe Bool +parseYesNo "YES" = Just True +parseYesNo "NO" = Just False +parseYesNo _ = Nothing + +-- | Pretty-print a 'Bool' as a @"0"@ or @"1"@ string +zeroOne :: Bool -> String +zeroOne False = "0" +zeroOne True = "1" + +-- | Normalise a path and convert all path separators to @/@, even on Windows. +unifyPath :: FilePath -> FilePath +unifyPath = toStandard . normaliseEx + +-- | Combine paths with a forward slash regardless of platform. +(-/-) :: FilePath -> FilePath -> FilePath +"" -/- b = b +a -/- b + | last a == '/' = a ++ b + | otherwise = a ++ '/' : b + +infixr 6 -/- + +-- | Like Shake's '%>' but gives higher priority to longer patterns. Useful +-- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@ +-- can be matched by the same file, such as @library_p.a@. We break the tie +-- by preferring longer matches, which correpond to longer patterns. +(%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules () +p %%> a = priority (fromIntegral (length p) + 1) $ p %> a + +infix 1 %%> + +-- | Build command lines can get very long; for example, when building the Cabal +-- library, they can reach 2MB! Some operating systems do not support command +-- lines of such length, and this function can be used to obtain a reasonable +-- approximation of the limit. On Windows, it is theoretically 32768 characters +-- (since Windows 7). In practice we use 31000 to leave some breathing space for +-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X, +-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over +-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems +-- we currently use the 4194304 setting. +cmdLineLengthLimit :: Int +cmdLineLengthLimit | isWindows = 31000 + | isMac = 200000 + | otherwise = 4194304 + +-- | Insert a value into Shake's type-indexed map. +insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic +insertExtra value = Map.insert (typeOf value) (toDyn value) + +-- | Lookup a value in Shake's type-indexed map. +lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a +lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue + where + maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra + +-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the +-- setting is not found, return the provided default value instead. +userSetting :: Typeable a => a -> Action a +userSetting defaultValue = do + extra <- shakeExtra <$> getShakeOptions + return $ lookupExtra defaultValue extra + +-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the +-- setting is not found, return the provided default value instead. +userSettingRules :: Typeable a => a -> Rules a +userSettingRules defaultValue = do + extra <- shakeExtra <$> getShakeOptionsRules + return $ lookupExtra defaultValue extra + +newtype BuildRoot = BuildRoot FilePath deriving (Typeable, Eq, Show) + +-- | All build results are put into the 'buildRoot' directory. +buildRoot :: Action FilePath +buildRoot = do + BuildRoot path <- userSetting (BuildRoot "") + return path + +buildRootRules :: Rules FilePath +buildRootRules = do + BuildRoot path <- userSettingRules (BuildRoot "") + return path + +-- | A version of 'fmap' with flipped arguments. Useful for manipulating values +-- in context, e.g. 'buildRoot', as in the example below. +-- +-- @ +-- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot +-- @ +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap + +infixl 1 <&> + +-- | Given a 'FilePath' to a source file, return 'True' if it is generated. +-- The current implementation simply assumes that a file is generated if it +-- lives in the 'buildRoot' directory. Since most files are not generated the +-- test is usually very fast. +isGeneratedSource :: FilePath -> Action Bool +isGeneratedSource file = buildRoot <&> (`isPrefixOf` file) + +-- | Copy a file tracking the source. Create the target directory if missing. +copyFile :: FilePath -> FilePath -> Action () +copyFile source target = do + need [source] -- Guarantee the source is built before printing progress info. + let dir = takeDirectory target + liftIO $ IO.createDirectoryIfMissing True dir + putProgressInfo =<< renderAction "Copy file" source target + quietly $ copyFileChanged source target + +-- | Copy a file without tracking the source. Create the target directory if missing. +copyFileUntracked :: FilePath -> FilePath -> Action () +copyFileUntracked source target = do + let dir = takeDirectory target + liftIO $ IO.createDirectoryIfMissing True dir + putProgressInfo =<< renderAction "Copy file (untracked)" source target + liftIO $ IO.copyFile source target + +-- | Transform a given file by applying a function to its contents. +fixFile :: FilePath -> (String -> String) -> Action () +fixFile file f = do + putProgressInfo $ "| Fix " ++ file + contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do + old <- IO.hGetContents h + let new = f old + IO.evaluate $ rnf new + return new + liftIO $ writeFile file contents + +-- | Make a given file executable by running the @chmod +x@ command. +makeExecutable :: FilePath -> Action () +makeExecutable file = do + putProgressInfo $ "| Make " ++ quote file ++ " executable." + quietly $ cmd "chmod +x " [file] + +-- | Move a file. Note that we cannot track the source, because it is moved. +moveFile :: FilePath -> FilePath -> Action () +moveFile source target = do + putProgressInfo =<< renderAction "Move file" source target + quietly $ cmd ["mv", source, target] + +-- | Remove a file that doesn't necessarily exist. +removeFile :: FilePath -> Action () +removeFile file = do + putProgressInfo $ "| Remove file " ++ file + liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file + +-- | Create a directory if it does not already exist. +createDirectory :: FilePath -> Action () +createDirectory dir = do + putProgressInfo $ "| Create directory " ++ dir + liftIO $ IO.createDirectoryIfMissing True dir + +-- | Copy a directory. The contents of the source directory is untracked. +copyDirectory :: FilePath -> FilePath -> Action () +copyDirectory source target = do + putProgressInfo =<< renderAction "Copy directory" source target + quietly $ cmd ["cp", "-r", source, target] + +-- | Move a directory. The contents of the source directory is untracked. +moveDirectory :: FilePath -> FilePath -> Action () +moveDirectory source target = do + putProgressInfo =<< renderAction "Move directory" source target + quietly $ cmd ["mv", source, target] + +-- | Remove a directory that doesn't necessarily exist. +removeDirectory :: FilePath -> Action () +removeDirectory dir = do + putProgressInfo $ "| Remove directory " ++ dir + liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir + +data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable) + +-- | Terminal output colours +data Colour + = Dull ANSIColour -- ^ 8-bit ANSI colours + | Vivid ANSIColour -- ^ 16-bit vivid ANSI colours + | Extended String -- ^ Extended 256-bit colours, manual code stored + +-- | ANSI terminal colours +data ANSIColour + = Black -- ^ ANSI code: 30 + | Red -- ^ 31 + | Green -- ^ 32 + | Yellow -- ^ 33 + | Blue -- ^ 34 + | Magenta -- ^ 35 + | Cyan -- ^ 36 + | White -- ^ 37 + | Reset -- ^ 0 + +-- | Convert ANSI colour names into their associated codes +colourCode :: ANSIColour -> String +colourCode Black = "30" +colourCode Red = "31" +colourCode Green = "32" +colourCode Yellow = "33" +colourCode Blue = "34" +colourCode Magenta = "35" +colourCode Cyan = "36" +colourCode White = "37" +colourCode Reset = "0" + +-- | Create the final ANSI code. +mkColour :: Colour -> String +mkColour (Dull c) = colourCode c +mkColour (Vivid c) = colourCode c ++ ";1" +mkColour (Extended code) = "38;5;" ++ code + +-- | A more colourful version of Shake's 'putNormal'. +putColoured :: String -> String -> Action () +putColoured code msg = do + useColour <- userSetting Never + supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout + <*> (not <$> isDumb) + let c Never = False + c Auto = supported || IO.isWindows -- Colours do work on Windows + c Always = True + if c useColour + then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m" + else putNormal msg + where + isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" + +newtype BuildProgressColour = BuildProgressColour String + deriving Typeable + +-- | Generate an encoded colour for progress output from names. +mkBuildProgressColour :: Colour -> BuildProgressColour +mkBuildProgressColour c = BuildProgressColour $ mkColour c + +-- | Default 'BuildProgressColour'. +magenta :: BuildProgressColour +magenta = mkBuildProgressColour (Dull Magenta) + +-- | Print a build progress message (e.g. executing a build command). +putBuild :: String -> Action () +putBuild msg = do + BuildProgressColour code <- userSetting magenta + putColoured code msg + +newtype SuccessColour = SuccessColour String + deriving Typeable + +-- | Generate an encoded colour for successful output from names +mkSuccessColour :: Colour -> SuccessColour +mkSuccessColour c = SuccessColour $ mkColour c + +-- | Default 'SuccessColour'. +green :: SuccessColour +green = mkSuccessColour (Dull Green) + +-- | Print a success message (e.g. a package is built successfully). +putSuccess :: String -> Action () +putSuccess msg = do + SuccessColour code <- userSetting green + putColoured code msg + +data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable) + +-- | Version of 'putBuild' controlled by @--progress-info@ command line argument. +putProgressInfo :: String -> Action () +putProgressInfo msg = do + progressInfo <- userSetting None + when (progressInfo /= None) $ putBuild msg + +-- | Render an action. +renderAction :: String -> FilePath -> FilePath -> Action String +renderAction what input output = do + progressInfo <- userSetting Brief + return $ case progressInfo of + None -> "" + Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o + Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ] + Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ] + where + i = unifyPath input + o = unifyPath output + +-- | Render an action. +renderActionNoOutput :: String -> FilePath -> Action String +renderActionNoOutput what input = do + progressInfo <- userSetting Brief + return $ case progressInfo of + None -> "" + Brief -> "| " ++ what ++ ": " ++ i + Normal -> renderBox [ what, " input: " ++ i ] + Unicorn -> renderUnicorn [ what, " input: " ++ i ] + where + i = unifyPath input + +-- | Render the successful build of a program. +renderProgram :: String -> String -> String -> String +renderProgram name bin synopsis = renderBox $ + [ "Successfully built program " ++ name + , "Executable: " ++ bin ] ++ + [ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ] + +-- | Render the successful build of a library. +renderLibrary :: String -> String -> String -> String +renderLibrary name lib synopsis = renderBox $ + [ "Successfully built library " ++ name + , "Library: " ++ lib ] ++ + [ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ] + +endWithADot :: String -> String +endWithADot s = dropWhileEnd isPunctuation s ++ "." + +-- | Render the given set of lines in an ASCII box. The minimum width and +-- whether to use Unicode symbols are hardcoded in the function's body. +-- +-- >>> renderBox (words "lorem ipsum") +-- /----------\ +-- | lorem | +-- | ipsum | +-- \----------/ +renderBox :: [String] -> String +renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot]) + where + -- Minimum total width of the box in characters + minimumBoxWidth = 32 + + -- TODO: Make this setting configurable? Setting to True by default seems + -- to work poorly with many fonts. + useUnicode = False + + -- Characters to draw the box + (dash, pipe, topLeft, topRight, botLeft, botRight, padding) + | useUnicode = ('─', '│', 'â•', 'â•®', 'â•°', '╯', ' ') + | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ') + + -- Box width, taking minimum desired length and content into account. + -- The -4 is for the beginning and end pipe/padding symbols, as + -- in "| xxx |". + boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength + where + maxContentLength = maximum (map length ls) + + renderLine l = concat + [ [pipe, padding] + , padToLengthWith boxContentWidth padding l + , [padding, pipe] ] + where + padToLengthWith n filler x = x ++ replicate (n - length x) filler + + (boxTop, boxBot) = ( topLeft : dashes ++ [topRight] + , botLeft : dashes ++ [botRight] ) + where + -- +1 for each non-dash (= corner) char + dashes = replicate (boxContentWidth + 2) dash + +-- | Render the given set of lines next to our favorite unicorn Robert. +renderUnicorn :: [String] -> String +renderUnicorn ls = + unlines $ take (max (length ponyLines) (length boxLines)) $ + zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "") + where + ponyLines :: [String] + ponyLines = [ " ,;,,;'" + , " ,;;'( Robert the spitting unicorn" + , " __ ,;;' ' \\ wants you to know" + , " /' '\\'~~'~' \\ /'\\.) that a task " + , " ,;( ) / |. / just finished! " + , " ,;' \\ /-.,,( ) \\ " + , " ^ ) / ) / )| Almost there! " + , " || || \\) " + , " (_\\ (_\\ " ] + ponyPadding :: String + ponyPadding = " " + boxLines :: [String] + boxLines = ["", "", ""] ++ (lines . renderBox $ ls) diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs new file mode 100644 index 0000000000..083e6838d8 --- /dev/null +++ b/hadrian/src/Main.hs @@ -0,0 +1,58 @@ +module Main (main) where + +import Development.Shake +import Hadrian.Expression +import Hadrian.Utilities + +import qualified Base +import qualified CommandLine +import qualified Environment +import qualified Rules +import qualified Rules.Clean +import qualified Rules.Documentation +import qualified Rules.Nofib +import qualified Rules.SourceDist +import qualified Rules.Selftest +import qualified Rules.Test +import qualified UserSettings + +main :: IO () +main = do + -- Provide access to command line arguments and some user settings through + -- Shake's type-indexed map 'shakeExtra'. + argsMap <- CommandLine.cmdLineArgsMap + let extra = insertExtra UserSettings.buildProgressColour + $ insertExtra UserSettings.successColour + $ insertExtra (VerboseCommand UserSettings.verboseCommand) argsMap + + BuildRoot buildRoot = CommandLine.lookupBuildRoot argsMap + + rebuild = [ (RebuildLater, buildRoot -/- "stage0//*") + | CommandLine.lookupFreeze1 argsMap ] + + options :: ShakeOptions + options = shakeOptions + { shakeChange = ChangeModtimeAndDigest + , shakeFiles = buildRoot -/- Base.shakeFilesDir + , shakeProgress = progressSimple + , shakeRebuild = rebuild + , shakeTimings = True + , shakeExtra = extra } + + rules :: Rules () + rules = do + Rules.buildRules + Rules.Documentation.documentationRules + Rules.Clean.cleanRules + Rules.Nofib.nofibRules + Rules.oracleRules + Rules.Selftest.selftestRules + Rules.SourceDist.sourceDistRules + Rules.Test.testRules + Rules.topLevelTargets + + shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do + Environment.setupEnvironment + return . Just $ if null targets + then rules + else want targets >> withoutActions rules diff --git a/hadrian/src/Oracles/Flag.hs b/hadrian/src/Oracles/Flag.hs new file mode 100644 index 0000000000..57dbf2decb --- /dev/null +++ b/hadrian/src/Oracles/Flag.hs @@ -0,0 +1,76 @@ +module Oracles.Flag ( + Flag (..), flag, getFlag, platformSupportsSharedLibs, ghcWithSMP, + ghcWithNativeCodeGen, supportsSplitObjects + ) where + +import Hadrian.Oracles.TextFile +import Hadrian.Expression + +import Base +import Oracles.Setting + +data Flag = ArSupportsAtFile + | CrossCompiling + | GccIsClang + | GhcUnregisterised + | LeadingUnderscore + | SolarisBrokenShld + | SplitObjectsBroken + | WithLibdw + | HaveLibMingwEx + | UseSystemFfi + +-- Note, if a flag is set to empty string we treat it as set to NO. This seems +-- fragile, but some flags do behave like this, e.g. GccIsClang. +flag :: Flag -> Action Bool +flag f = do + let key = case f of + ArSupportsAtFile -> "ar-supports-at-file" + CrossCompiling -> "cross-compiling" + GccIsClang -> "gcc-is-clang" + GhcUnregisterised -> "ghc-unregisterised" + LeadingUnderscore -> "leading-underscore" + SolarisBrokenShld -> "solaris-broken-shld" + SplitObjectsBroken -> "split-objects-broken" + WithLibdw -> "with-libdw" + HaveLibMingwEx -> "have-lib-mingw-ex" + UseSystemFfi -> "use-system-ffi" + value <- lookupValueOrError configFile key + when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag " + ++ quote (key ++ " = " ++ value) ++ " cannot be parsed." + return $ value == "YES" + +-- | Get a configuration setting. +getFlag :: Flag -> Expr c b Bool +getFlag = expr . flag + +platformSupportsSharedLibs :: Action Bool +platformSupportsSharedLibs = do + badPlatform <- anyTargetPlatform [ "powerpc-unknown-linux" + , "x86_64-unknown-mingw32" + , "i386-unknown-mingw32" ] + solaris <- anyTargetPlatform [ "i386-unknown-solaris2" ] + solarisBroken <- flag SolarisBrokenShld + return $ not (badPlatform || solaris && solarisBroken) + +ghcWithSMP :: Action Bool +ghcWithSMP = do + goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc", "arm"] + ghcUnreg <- flag GhcUnregisterised + return $ goodArch && not ghcUnreg + +ghcWithNativeCodeGen :: Action Bool +ghcWithNativeCodeGen = do + goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc"] + badOs <- anyTargetOs ["ios", "aix"] + ghcUnreg <- flag GhcUnregisterised + return $ goodArch && not badOs && not ghcUnreg + +supportsSplitObjects :: Action Bool +supportsSplitObjects = do + broken <- flag SplitObjectsBroken + ghcUnreg <- flag GhcUnregisterised + goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc" ] + goodOs <- anyTargetOs [ "mingw32", "cygwin32", "linux", "darwin", "solaris2" + , "freebsd", "dragonfly", "netbsd", "openbsd" ] + return $ not broken && not ghcUnreg && goodArch && goodOs diff --git a/hadrian/src/Oracles/ModuleFiles.hs b/hadrian/src/Oracles/ModuleFiles.hs new file mode 100644 index 0000000000..1e508c0090 --- /dev/null +++ b/hadrian/src/Oracles/ModuleFiles.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TypeFamilies #-} +module Oracles.ModuleFiles ( + decodeModule, encodeModule, findGenerator, hsSources, hsObjects, + moduleFilesOracle + ) where + +import qualified Data.HashMap.Strict as Map +import Hadrian.Haskell.Cabal.Type as PD + +import Base +import Builder +import Context +import Expression +import Packages + +type ModuleName = String + +newtype ModuleFiles = ModuleFiles (Stage, Package) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult ModuleFiles = [Maybe FilePath] + +newtype Generator = Generator (Stage, Package, FilePath) + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult Generator = Maybe FilePath + +-- | We scan for the following Haskell source extensions when looking for module +-- files. Note, we do not list "*.(l)hs-boot" files here, as they can never +-- appear by themselves and always have accompanying "*.(l)hs" master files. +haskellExtensions :: [String] +haskellExtensions = [".hs", ".lhs"] + +-- | Non-Haskell source extensions and corresponding builders. +otherExtensions :: Stage -> [(String, Builder)] +otherExtensions stage = [ (".x" , Alex ) + , (".y" , Happy ) + , (".ly" , Happy ) + , (".hsc", Hsc2Hs stage) ] + +-- | We match the following file patterns when looking for module files. +moduleFilePatterns :: Stage -> [FilePattern] +moduleFilePatterns stage = map ("*" ++) $ haskellExtensions ++ map fst (otherExtensions stage) + +-- | Given a FilePath determine the corresponding builder. +determineBuilder :: Stage -> FilePath -> Maybe Builder +determineBuilder stage file = lookup (takeExtension file) (otherExtensions stage) + +-- | Given a non-empty module name extract the directory and file name, e.g.: +-- +-- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity") +-- > decodeModule "Prelude" == ("", "Prelude") +decodeModule :: ModuleName -> (FilePath, String) +decodeModule moduleName = (intercalate "/" (init xs), last xs) + where + xs = words $ replaceEq '.' ' ' moduleName + +-- | Given the directory and file name find the corresponding module name, e.g.: +-- +-- > encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity" +-- > encodeModule "" "Prelude" == "Prelude" +-- > uncurry encodeModule (decodeModule name) == name +encodeModule :: FilePath -> String -> ModuleName +encodeModule dir file + | dir == "" = takeBaseName file + | otherwise = replaceEq '/' '.' dir ++ '.' : takeBaseName file + +-- | Find the generator for a given 'Context' and a source file. For example: +-- findGenerator (Context Stage1 compiler vanilla) +-- "_build/stage1/compiler/build/Lexer.hs" +-- == Just ("compiler/parser/Lexer.x", Alex) +-- findGenerator (Context Stage1 base vanilla) +-- "_build/stage1/base/build/Prelude.hs" +-- == Nothing +findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder)) +findGenerator Context {..} file = do + maybeSource <- askOracle $ Generator (stage, package, file) + return $ do + source <- maybeSource + builder <- determineBuilder stage source + return (source, builder) + +-- | Find all Haskell source files for a given 'Context'. +hsSources :: Context -> Action [FilePath] +hsSources context = do + let modFile (m, Nothing ) = generatedFile context m + modFile (m, Just file ) + | takeExtension file `elem` haskellExtensions = return file + | otherwise = generatedFile context m + mapM modFile =<< contextFiles context + +-- | Find all Haskell object files for a given 'Context'. Note: this is a much +-- simpler function compared to 'hsSources', because all object files live in +-- the build directory regardless of whether they are generated or not. +hsObjects :: Context -> Action [FilePath] +hsObjects context = do + modules <- interpretInContext context (getContextData PD.modules) + mapM (objectPath context . moduleSource) modules + +-- | Generated module files live in the 'Context' specific build directory. +generatedFile :: Context -> ModuleName -> Action FilePath +generatedFile context moduleName = buildPath context <&> (-/- moduleSource moduleName) + +-- | Turn a module name (e.g. @Data.Functor@) to a path (e.g. @Data/Functor.hs@). +moduleSource :: ModuleName -> FilePath +moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs" + +-- | Module files for a given 'Context'. +contextFiles :: Context -> Action [(ModuleName, Maybe FilePath)] +contextFiles context@Context {..} = do + modules <- fmap sort . interpretInContext context $ + getContextData PD.modules + zip modules <$> askOracle (ModuleFiles (stage, package)) + +-- | This is an important oracle whose role is to find and cache module source +-- files. It takes a 'Stage' and a 'Package', looks up corresponding source +-- directories @dirs@ and a sorted list of module names @modules@, and for each +-- module, e.g. @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@, +-- such that @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or +-- 'Nothing' if there is no such file. If more than one matching file is found +-- an error is raised. For example, for 'Stage1' and 'compiler', @dirs@ will +-- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain +-- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list +-- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing, +-- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files. +moduleFilesOracle :: Rules () +moduleFilesOracle = void $ do + void . addOracleCache $ \(ModuleFiles (stage, package)) -> do + let context = vanillaContext stage package + srcDirs <- interpretInContext context (getContextData PD.srcDirs) + mainIs <- interpretInContext context (getContextData PD.mainIs) + let removeMain = case mainIs of + Just (mod, _) -> delete mod + Nothing -> id + modules <- fmap sort $ interpretInContext context (getContextData PD.modules) + autogen <- autogenPath context + let dirs = autogen : map (pkgPath package -/-) srcDirs + -- Don't resolve the file path for module `Main` twice. + modDirFiles = groupSort $ map decodeModule $ removeMain modules + result <- concatForM dirs $ \dir -> do + todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles + forM todo $ \(mDir, mFiles) -> do + let fullDir = unifyPath $ dir -/- mDir + files <- getDirectoryFiles fullDir (moduleFilePatterns stage) + let cmp f = compare (dropExtension f) + found = intersectOrd cmp files mFiles + return (map (fullDir -/-) found, mDir) + + -- For a BuildInfo, it may be a library, which doesn't have the @Main@ + -- module, or an executable, which must have the @Main@ module and the + -- file path of @Main@ module is indicated by the @main-is@ field in its + -- Cabal file. + -- + -- For the Main module, the file name may not be @Main.hs@, unlike other + -- exposed modules. We could get the file path by the module name for + -- other exposed modules, but for @Main@ we must resolve the file path + -- via the @main-is@ field in the Cabal file. + mainpairs <- case mainIs of + Just (mod, filepath) -> + concatForM dirs $ \dir -> do + found <- doesFileExist (dir -/- filepath) + return [(mod, unifyPath $ dir -/- filepath) | found] + Nothing -> return [] + + let pairs = sort $ mainpairs ++ [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ] + multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ] + unless (null multi) $ do + let (m, f1, f2) = head multi + error $ "Module " ++ m ++ " has more than one source file: " + ++ f1 ++ " and " ++ f2 ++ "." + return $ lookupAll modules pairs + + -- Optimisation: we discard Haskell files here, because they are never used + -- as generators, and hence would be discarded in 'findGenerator' anyway. + generators <- newCache $ \(stage, package) -> do + let context = vanillaContext stage package + files <- contextFiles context + list <- sequence [ (,src) <$> generatedFile context modName + | (modName, Just src) <- files + , takeExtension src `notElem` haskellExtensions ] + return $ Map.fromList list + + addOracleCache $ \(Generator (stage, package, file)) -> + Map.lookup file <$> generators (stage, package) diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs new file mode 100644 index 0000000000..1cdcddf186 --- /dev/null +++ b/hadrian/src/Oracles/Setting.hs @@ -0,0 +1,221 @@ +module Oracles.Setting ( + configFile, Setting (..), SettingList (..), setting, settingList, getSetting, + getSettingList, anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs, + ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors, + ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost, + topDirectory, libsuf + ) where + +import Hadrian.Expression +import Hadrian.Oracles.TextFile +import Hadrian.Oracles.Path + +import Base + +-- | Each 'Setting' comes from the file @hadrian/cfg/system.config@, generated +-- by the @configure@ script from the input file @hadrian/cfg/system.config.in@. +-- For example, the line +-- +-- > target-os = mingw32 +-- +-- sets the value of the setting 'TargetOs'. The action 'setting' 'TargetOs' +-- looks up the value of the setting and returns the string @"mingw32"@, +-- tracking the result in the Shake database. +data Setting = BuildArch + | BuildOs + | BuildPlatform + | BuildVendor + | CcClangBackend + | CcLlvmBackend + | CursesLibDir + | DynamicExtension + | FfiIncludeDir + | FfiLibDir + | GhcMajorVersion + | GhcMinorVersion + | GhcPatchLevel + | GhcVersion + | GhcSourcePath + | GmpIncludeDir + | GmpLibDir + | HostArch + | HostOs + | HostPlatform + | HostVendor + | IconvIncludeDir + | IconvLibDir + | LlvmTarget + | ProjectGitCommitId + | ProjectName + | ProjectVersion + | ProjectVersionInt + | ProjectPatchLevel + | ProjectPatchLevel1 + | ProjectPatchLevel2 + | SystemGhc + | TargetArch + | TargetOs + | TargetPlatform + | TargetPlatformFull + | TargetVendor + +-- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). +-- | Each 'SettingList' comes from the file @hadrian/cfg/system.config@, +-- generated by the @configure@ script from the input file +-- @hadrian/cfg/system.config.in@. For example, the line +-- +-- > hs-cpp-args = -E -undef -traditional +-- +-- sets the value of 'HsCppArgs'. The action 'settingList' 'HsCppArgs' looks up +-- the value of the setting and returns the list of strings +-- @["-E", "-undef", "-traditional"]@, tracking the result in the Shake database. +data SettingList = ConfCcArgs Stage + | ConfCppArgs Stage + | ConfGccLinkerArgs Stage + | ConfLdLinkerArgs Stage + | HsCppArgs + +-- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the +-- result. +setting :: Setting -> Action String +setting key = lookupValueOrError configFile $ case key of + BuildArch -> "build-arch" + BuildOs -> "build-os" + BuildPlatform -> "build-platform" + BuildVendor -> "build-vendor" + CcClangBackend -> "cc-clang-backend" + CcLlvmBackend -> "cc-llvm-backend" + CursesLibDir -> "curses-lib-dir" + DynamicExtension -> "dynamic-extension" + FfiIncludeDir -> "ffi-include-dir" + FfiLibDir -> "ffi-lib-dir" + GhcMajorVersion -> "ghc-major-version" + GhcMinorVersion -> "ghc-minor-version" + GhcPatchLevel -> "ghc-patch-level" + GhcVersion -> "ghc-version" + GhcSourcePath -> "ghc-source-path" + GmpIncludeDir -> "gmp-include-dir" + GmpLibDir -> "gmp-lib-dir" + HostArch -> "host-arch" + HostOs -> "host-os" + HostPlatform -> "host-platform" + HostVendor -> "host-vendor" + IconvIncludeDir -> "iconv-include-dir" + IconvLibDir -> "iconv-lib-dir" + LlvmTarget -> "llvm-target" + ProjectGitCommitId -> "project-git-commit-id" + ProjectName -> "project-name" + ProjectVersion -> "project-version" + ProjectVersionInt -> "project-version-int" + ProjectPatchLevel -> "project-patch-level" + ProjectPatchLevel1 -> "project-patch-level1" + ProjectPatchLevel2 -> "project-patch-level2" + SystemGhc -> "system-ghc" + TargetArch -> "target-arch" + TargetOs -> "target-os" + TargetPlatform -> "target-platform" + TargetPlatformFull -> "target-platform-full" + TargetVendor -> "target-vendor" + +-- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the +-- result. +settingList :: SettingList -> Action [String] +settingList key = fmap words $ lookupValueOrError configFile $ case key of + ConfCcArgs stage -> "conf-cc-args-" ++ stageString stage + ConfCppArgs stage -> "conf-cpp-args-" ++ stageString stage + ConfGccLinkerArgs stage -> "conf-gcc-linker-args-" ++ stageString stage + ConfLdLinkerArgs stage -> "conf-ld-linker-args-" ++ stageString stage + HsCppArgs -> "hs-cpp-args" + +-- | An expression that looks up the value of a 'Setting' in @cfg/system.config@, +-- tracking the result. +getSetting :: Setting -> Expr c b String +getSetting = expr . setting + +-- | An expression that looks up the value of a 'SettingList' in +-- @cfg/system.config@, tracking the result. +getSettingList :: SettingList -> Args c b +getSettingList = expr . settingList + +-- | Check whether the value of a 'Setting' matches one of the given strings. +matchSetting :: Setting -> [String] -> Action Bool +matchSetting key values = (`elem` values) <$> setting key + +-- | Check whether the target platform setting matches one of the given strings. +anyTargetPlatform :: [String] -> Action Bool +anyTargetPlatform = matchSetting TargetPlatformFull + +-- | Check whether the target OS setting matches one of the given strings. +anyTargetOs :: [String] -> Action Bool +anyTargetOs = matchSetting TargetOs + +-- | Check whether the target architecture setting matches one of the given +-- strings. +anyTargetArch :: [String] -> Action Bool +anyTargetArch = matchSetting TargetArch + +-- | Check whether the host OS setting matches one of the given strings. +anyHostOs :: [String] -> Action Bool +anyHostOs = matchSetting HostOs + +-- | Check whether the host OS setting is set to @"ios"@. +iosHost :: Action Bool +iosHost = anyHostOs ["ios"] + +-- | Check whether the host OS setting is set to @"darwin"@. +osxHost :: Action Bool +osxHost = anyHostOs ["darwin"] + +-- | Check whether the host OS setting is set to @"mingw32"@ or @"cygwin32"@. +windowsHost :: Action Bool +windowsHost = anyHostOs ["mingw32", "cygwin32"] + +-- | Check whether the target supports GHCi. +ghcWithInterpreter :: Action Bool +ghcWithInterpreter = do + goodOs <- anyTargetOs [ "mingw32", "cygwin32", "linux", "solaris2" + , "freebsd", "dragonfly", "netbsd", "openbsd" + , "darwin", "kfreebsdgnu" ] + goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc" + , "sparc64", "arm" ] + return $ goodOs && goodArch + +-- | Check whether the target architecture supports placing info tables next to +-- code. See: https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects#TABLES_NEXT_TO_CODE. +ghcEnableTablesNextToCode :: Action Bool +ghcEnableTablesNextToCode = notM $ anyTargetArch ["ia64", "powerpc64", "powerpc64le"] + +-- | Check to use @libffi@ for adjustors. +useLibFFIForAdjustors :: Action Bool +useLibFFIForAdjustors = notM $ anyTargetArch ["i386", "x86_64"] + +-- | Canonicalised GHC version number, used for integer version comparisons. We +-- expand 'GhcMinorVersion' to two digits by adding a leading zero if necessary. +ghcCanonVersion :: Action String +ghcCanonVersion = do + ghcMajorVersion <- setting GhcMajorVersion + ghcMinorVersion <- setting GhcMinorVersion + let leadingZero = [ '0' | length ghcMinorVersion == 1 ] + return $ ghcMajorVersion ++ leadingZero ++ ghcMinorVersion + +-- | Path to the GHC source tree. +topDirectory :: Action FilePath +topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath + +-- | The file suffix used for libraries of a given build 'Way'. For example, +-- @_p.a@ corresponds to a static profiled library, and @-ghc7.11.20141222.so@ +-- is a dynamic vanilly library. Why do we need GHC version number in the +-- dynamic suffix? Here is a possible reason: dynamic libraries are placed in a +-- single giant directory in the load path of the dynamic linker, and hence we +-- must distinguish different versions of GHC. In contrast, static libraries +-- live in their own per-package directory and hence do not need a unique +-- filename. We also need to respect the system's dynamic extension, e.g. @.dll@ +-- or @.so@. +libsuf :: Way -> Action String +libsuf way + | not (wayUnit Dynamic way) = return (waySuffix way ++ ".a") -- e.g., _p.a + | otherwise = do + extension <- setting DynamicExtension -- e.g., .dll or .so + version <- setting ProjectVersion -- e.g., 7.11.20141222 + let suffix = waySuffix (removeWayUnit Dynamic way) + return ("-ghc" ++ version ++ suffix ++ extension) diff --git a/hadrian/src/Oracles/TestSettings.hs b/hadrian/src/Oracles/TestSettings.hs new file mode 100644 index 0000000000..1bf75b527d --- /dev/null +++ b/hadrian/src/Oracles/TestSettings.hs @@ -0,0 +1,69 @@ +-- | We create a file <root>/test/ghcconfig containing configuration of test +-- | compiler. We need to search this file for required keys and setting +-- | required for testsuite e.g. WORDSIZE, HOSTOS etc. + +module Oracles.TestSettings (TestSetting (..), testSetting, testRTSSettings) where + +import Base +import Hadrian.Oracles.TextFile + +testConfigFile :: Action FilePath +testConfigFile = buildRoot <&> (-/- "test/ghcconfig") + +-- | Test settings that are obtained from ghcconfig file. +data TestSetting = TestHostOS + | TestWORDSIZE + | TestTARGETPLATFORM + | TestTargetOS_CPP + | TestTargetARCH_CPP + | TestGhcStage + | TestGhcDebugged + | TestGhcWithNativeCodeGen + | TestGhcWithInterpreter + | TestGhcUnregisterised + | TestGhcWithSMP + | TestGhcDynamicByDefault + | TestGhcDynamic + | TestGhcProfiled + | TestAR + | TestCLANG + | TestLLC + | TestTEST_CC + | TestGhcPackageDbFlag + | TestMinGhcVersion711 + | TestMinGhcVersion801 + deriving (Show) + +-- | Lookup a test setting in @ghcconfig@ file. +-- | To obtain RTS ways supported in @ghcconfig@ file, use 'testRTSSettings'. +testSetting :: TestSetting -> Action String +testSetting key = do + file <- testConfigFile + lookupValueOrError file $ case key of + TestHostOS -> "HostOS" + TestWORDSIZE -> "WORDSIZE" + TestTARGETPLATFORM -> "TARGETPLATFORM" + TestTargetOS_CPP -> "TargetOS_CPP" + TestTargetARCH_CPP -> "TargetARCH_CPP" + TestGhcStage -> "GhcStage" + TestGhcDebugged -> "GhcDebugged" + TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen" + TestGhcWithInterpreter -> "GhcWithInterpreter" + TestGhcUnregisterised -> "GhcUnregisterised" + TestGhcWithSMP -> "GhcWithSMP" + TestGhcDynamicByDefault -> "GhcDynamicByDefault" + TestGhcDynamic -> "GhcDynamic" + TestGhcProfiled -> "GhcProfiled" + TestAR -> "AR" + TestCLANG -> "CLANG" + TestLLC -> "LLC" + TestTEST_CC -> "TEST_CC" + TestGhcPackageDbFlag -> "GhcPackageDbFlag" + TestMinGhcVersion711 -> "MinGhcVersion711" + TestMinGhcVersion801 -> "MinGhcVersion801" + +-- | Get the RTS ways of the test compiler +testRTSSettings :: Action [String] +testRTSSettings = do + file <- testConfigFile + words <$> lookupValueOrError file "GhcRTSWays" diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs new file mode 100644 index 0000000000..8a9a48faf5 --- /dev/null +++ b/hadrian/src/Packages.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Packages ( + -- * GHC packages + array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr, + compareSizes, compiler, containers, deepseq, deriveConstants, directory, + filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact, + ghcHeap, ghci, ghcPkg, ghcPrim, ghcTags, ghcSplit, haddock, haskeline, + hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, + libiserv, mtl, parsec, parallel, pretty, primitive, process, rts, runGhc, + stm, templateHaskell, terminfo, text, time, timeout, touchy, transformers, + unlit, unix, win32, xhtml, ghcPackages, isGhcPackage, + + -- * Package information + programName, nonHsMainPackage, autogenPath, programPath, timeoutPath, + rtsContext, rtsBuildPath, libffiContext, libffiBuildPath, libffiLibraryName + ) where + +import Hadrian.Package +import Hadrian.Utilities + +import Base +import Context +import Oracles.Flag +import Oracles.Setting + +-- | These are all GHC packages we know about. Build rules will be generated for +-- all of them. However, not all of these packages will be built. For example, +-- package 'win32' is built only on Windows. @GHC.defaultPackages@ defines +-- default conditions for building each package. Users can add their own +-- packages and modify build default build conditions in "UserSettings". +ghcPackages :: [Package] +ghcPackages = + [ array, base, binary, bytestring, cabal, checkPpr, checkApiAnnotations + , compareSizes, compiler, containers, deepseq, deriveConstants, directory + , filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact + , ghcHeap, ghci, ghcPkg, ghcPrim, ghcTags, haddock, haskeline, hsc2hs, hp2ps + , hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl + , parsec, parallel, pretty, process, rts, runGhc, stm, templateHaskell + , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml + , timeout ] + +-- TODO: Optimise by switching to sets of packages. +isGhcPackage :: Package -> Bool +isGhcPackage = (`elem` ghcPackages) + +-- | Package definitions, see 'Package'. +array = lib "array" +base = lib "base" +binary = lib "binary" +bytestring = lib "bytestring" +cabal = lib "Cabal" `setPath` "libraries/Cabal/Cabal" +checkApiAnnotations = util "check-api-annotations" +checkPpr = util "check-ppr" +compareSizes = util "compareSizes" `setPath` "utils/compare_sizes" +compiler = top "ghc" `setPath` "compiler" +containers = lib "containers" +deepseq = lib "deepseq" +deriveConstants = util "deriveConstants" +directory = lib "directory" +filepath = lib "filepath" +genapply = util "genapply" +genprimopcode = util "genprimopcode" +ghc = prg "ghc-bin" `setPath` "ghc" +ghcBoot = lib "ghc-boot" +ghcBootTh = lib "ghc-boot-th" +ghcCompact = lib "ghc-compact" +ghcHeap = lib "ghc-heap" +ghci = lib "ghci" +ghcPkg = util "ghc-pkg" +ghcPrim = lib "ghc-prim" +ghcTags = util "ghctags" +ghcSplit = util "ghc-split" +haddock = util "haddock" +haskeline = lib "haskeline" +hsc2hs = util "hsc2hs" +hp2ps = util "hp2ps" +hpc = lib "hpc" +hpcBin = util "hpc-bin" `setPath` "utils/hpc" +integerGmp = lib "integer-gmp" +integerSimple = lib "integer-simple" +iserv = util "iserv" +libffi = top "libffi" +libiserv = lib "libiserv" +mtl = lib "mtl" +parsec = lib "parsec" +parallel = lib "parallel" +pretty = lib "pretty" +primitive = lib "primitive" +process = lib "process" +rts = top "rts" +runGhc = util "runghc" +stm = lib "stm" +templateHaskell = lib "template-haskell" +terminfo = lib "terminfo" +text = lib "text" +time = lib "time" +timeout = util "timeout" `setPath` "testsuite/timeout" +touchy = util "touchy" +transformers = lib "transformers" +unlit = util "unlit" +unix = lib "unix" +win32 = lib "Win32" +xhtml = lib "xhtml" + +-- | Construct a library package, e.g. @array@. +lib :: PackageName -> Package +lib name = library name ("libraries" -/- name) + +-- | Construct a top-level library package, e.g. @compiler@. +top :: PackageName -> Package +top name = library name name + +-- | Construct a top-level program package, e.g. @ghc@. +prg :: PackageName -> Package +prg name = program name name + +-- | Construct a utility package, e.g. @haddock@. +util :: PackageName -> Package +util name = program name ("utils" -/- name) + +-- | Amend a package path if it doesn't conform to a typical pattern. +setPath :: Package -> FilePath -> Package +setPath pkg path = pkg { pkgPath = path } + +-- | Given a 'Context', compute the name of the program that is built in it +-- assuming that the corresponding package's type is 'Program'. For example, GHC +-- built in 'Stage0' is called @ghc-stage1@. If the given package is a +-- 'Library', the function simply returns its name. +programName :: Context -> Action String +programName Context {..} = do + cross <- flag CrossCompiling + targetPlatform <- setting TargetPlatformFull + let prefix = if cross then targetPlatform ++ "-" else "" + -- TODO: Can we extract this information from Cabal files? + return $ prefix ++ case package of + p | p == ghc -> "ghc" + | p == hpcBin -> "hpc" + | p == iserv -> "ghc-iserv" + _ -> pkgName package + +-- | The 'FilePath' to a program executable in a given 'Context'. +programPath :: Context -> Action FilePath +programPath context@Context {..} = do + -- TODO: The @touchy@ utility lives in the @lib/bin@ directory instead of + -- @bin@, which is likely just a historical accident that should be fixed. + -- See: https://github.com/snowleopard/hadrian/issues/570 + -- Likewise for 'unlit'. + name <- programName context + path <- if package `elem` [touchy, unlit] then stageLibPath stage <&> (-/- "bin") + else stageBinPath stage + return $ path -/- name <.> exe + +-- TODO: Move @timeout@ to the @util@ directory and build in a more standard +-- location like other programs used only by the testsuite. +timeoutPath :: FilePath +timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe + +-- TODO: Can we extract this information from Cabal files? +-- | Some program packages should not be linked with Haskell main function. +nonHsMainPackage :: Package -> Bool +nonHsMainPackage = (`elem` [ghc, hp2ps, iserv, touchy, unlit]) + +-- TODO: Can we extract this information from Cabal files? +-- | Path to the @autogen@ directory generated when configuring a package. +autogenPath :: Context -> Action FilePath +autogenPath context@Context {..} + | isLibrary package = autogen "build" + | package == ghc = autogen "build/ghc" + | package == hpcBin = autogen "build/hpc" + | otherwise = autogen $ "build" -/- pkgName package + where + autogen dir = contextPath context <&> (-/- dir -/- "autogen") + +-- | RTS is considered a Stage1 package. +rtsContext :: Context +rtsContext = vanillaContext Stage1 rts + +-- | Path to the RTS build directory. +rtsBuildPath :: Action FilePath +rtsBuildPath = buildPath rtsContext + +-- | The 'libffi' library is considered a 'Stage1' package. +libffiContext :: Context +libffiContext = vanillaContext Stage1 libffi + +-- | Build directory for in-tree 'libffi' library. +libffiBuildPath :: Action FilePath +libffiBuildPath = buildPath libffiContext + +-- | Name of the 'libffi' library. +libffiLibraryName :: Action FilePath +libffiLibraryName = do + useSystemFfi <- flag UseSystemFfi + windows <- windowsHost + return $ case (useSystemFfi, windows) of + (True , False) -> "ffi" + (False, False) -> "Cffi" + (_ , True ) -> "Cffi-6" diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs new file mode 100644 index 0000000000..852bd5dbc8 --- /dev/null +++ b/hadrian/src/Rules.hs @@ -0,0 +1,143 @@ +module Rules (buildRules, oracleRules, packageTargets, topLevelTargets) where + +import qualified Hadrian.Oracles.ArgsHash +import qualified Hadrian.Oracles.Cabal.Rules +import qualified Hadrian.Oracles.DirectoryContents +import qualified Hadrian.Oracles.Path +import qualified Hadrian.Oracles.TextFile + +import Expression +import qualified Oracles.ModuleFiles +import Packages +import qualified Rules.BinaryDist +import qualified Rules.Compile +import qualified Rules.Configure +import qualified Rules.Dependencies +import qualified Rules.Documentation +import qualified Rules.Generate +import qualified Rules.Gmp +import qualified Rules.Libffi +import qualified Rules.Library +import qualified Rules.Program +import qualified Rules.Register +import Settings +import Target +import UserSettings +import Utilities + +allStages :: [Stage] +allStages = [minBound .. maxBound] + +-- | This rule calls 'need' on all top-level build targets that Hadrian builds +-- by default, respecting the 'stage1Only' flag. +topLevelTargets :: Rules () +topLevelTargets = action $ do + verbosity <- getVerbosity + when (verbosity >= Loud) $ do + (libraries, programs) <- partition isLibrary <$> stagePackages Stage1 + libNames <- mapM (name Stage1) libraries + pgmNames <- mapM (name Stage1) programs + putNormal . unlines $ + [ "| Building Stage1 libraries: " ++ intercalate ", " libNames + , "| Building Stage1 programs : " ++ intercalate ", " pgmNames ] + let buildStages = [Stage0, Stage1] ++ [Stage2 | not stage1Only] + targets <- concatForM buildStages $ \stage -> do + packages <- stagePackages stage + mapM (path stage) packages + need targets + where + -- either the package database config file for libraries or + -- the programPath for programs. However this still does + -- not support multiple targets, where a cabal package has + -- a library /and/ a program. + path :: Stage -> Package -> Action FilePath + path stage pkg | isLibrary pkg = pkgConfFile (vanillaContext stage pkg) + | otherwise = programPath =<< programContext stage pkg + name :: Stage -> Package -> Action String + name stage pkg | isLibrary pkg = return (pkgName pkg) + | otherwise = programName (vanillaContext stage pkg) + +-- TODO: Get rid of the @includeGhciLib@ hack. +-- | Return the list of targets associated with a given 'Stage' and 'Package'. +-- By setting the Boolean parameter to False it is possible to exclude the GHCi +-- library from the targets, and avoid configuring the package to determine +-- whether GHCi library needs to be built for it. We typically want to set +-- this parameter to True, however it is important to set it to False when +-- computing 'topLevelTargets', as otherwise the whole build gets sequentialised +-- because packages are configured in the order respecting their dependencies. +packageTargets :: Bool -> Stage -> Package -> Action [FilePath] +packageTargets includeGhciLib stage pkg = do + let context = vanillaContext stage pkg + activePackages <- stagePackages stage + if pkg `notElem` activePackages + then return [] -- Skip inactive packages. + else if isLibrary pkg + then do -- Collect all targets of a library package. + let pkgWays = if pkg == rts then getRtsWays else getLibraryWays + ways <- interpretInContext context pkgWays + libs <- mapM (pkgLibraryFile . Context stage pkg) ways + more <- libraryTargets includeGhciLib context + setup <- pkgSetupConfigFile context + return $ [setup] ++ libs ++ more + else do -- The only target of a program package is the executable. + prgContext <- programContext stage pkg + prgPath <- programPath prgContext + return [prgPath] + +packageRules :: Rules () +packageRules = do + -- We cannot register multiple GHC packages in parallel. Also we cannot run + -- GHC when the package database is being mutated by "ghc-pkg". This is a + -- classic concurrent read exclusive write (CREW) conflict. + let maxConcurrentReaders = 1000 + packageDb <- newResource "package-db" maxConcurrentReaders + let readPackageDb = [(packageDb, 1)] + writePackageDb = [(packageDb, maxConcurrentReaders)] + + let contexts = liftM3 Context allStages knownPackages allWays + vanillaContexts = liftM2 vanillaContext allStages knownPackages + + -- TODO: we might want to look into converting more and more + -- rules to the style introduced in Rules.Library in + -- https://github.com/snowleopard/hadrian/pull/571, + -- where "catch-all" rules are used to "catch" the need + -- for library files, and we then use parsec parsers to + -- extract all sorts of information needed to build them, like + -- the package, the stage, the way, etc. + + forM_ contexts (Rules.Compile.compilePackage readPackageDb) + + Rules.Program.buildProgram readPackageDb + + forM_ [Stage0 .. ] $ \stage -> + -- we create a dummy context, that has the correct state, but contains + -- @dummyPackage@ as a... dummy package. The package isn't accessed but the record + -- need to be set properly. @undefined@ is not an option as it ends up + -- being forced. + Rules.Register.registerPackage writePackageDb (Context stage dummyPackage vanilla) + + forM_ vanillaContexts $ mconcat + [ Rules.Register.configurePackage + , Rules.Dependencies.buildPackageDependencies readPackageDb + , Rules.Documentation.buildPackageDocumentation + , Rules.Generate.generatePackageCode ] + +buildRules :: Rules () +buildRules = do + Rules.BinaryDist.bindistRules + Rules.Configure.configureRules + Rules.Generate.copyRules + Rules.Generate.generateRules + Rules.Gmp.gmpRules + Rules.Libffi.libffiRules + Rules.Library.libraryRules + packageRules + +oracleRules :: Rules () +oracleRules = do + Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs + Hadrian.Oracles.Cabal.Rules.cabalOracle + Hadrian.Oracles.DirectoryContents.directoryContentsOracle + Hadrian.Oracles.Path.pathOracle + Hadrian.Oracles.TextFile.textFileOracle + Oracles.ModuleFiles.moduleFilesOracle diff --git a/hadrian/src/Rules/BinaryDist.hs b/hadrian/src/Rules/BinaryDist.hs new file mode 100644 index 0000000000..f0aeb4b827 --- /dev/null +++ b/hadrian/src/Rules/BinaryDist.hs @@ -0,0 +1,294 @@ +module Rules.BinaryDist where + +import Hadrian.Haskell.Cabal + +import Context +import Expression +import Oracles.Setting +import Packages +import Settings +import Target +import Utilities + +bindistRules :: Rules () +bindistRules = do + root <- buildRootRules + phony "binary-dist" $ do + -- We 'need' all binaries and libraries + targets <- mapM pkgTarget =<< stagePackages Stage1 + need targets + version <- setting ProjectVersion + targetPlatform <- setting TargetPlatformFull + hostOs <- setting BuildOs + hostArch <- setting BuildArch + rtsDir <- pkgIdentifier rts + + let ghcBuildDir = root -/- stageString Stage1 + bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty + ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform + distDir = hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version + rtsIncludeDir = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir + -/- "include" + + -- We create the bindist directory at <root>/bindist/ghc-X.Y.Z-platform/ + -- and populate it with Stage2 build results + createDirectory bindistFilesDir + copyDirectory (ghcBuildDir -/- "bin") bindistFilesDir + copyDirectory (ghcBuildDir -/- "lib") bindistFilesDir + copyDirectory (rtsIncludeDir) bindistFilesDir + {- TODO: Should we ship docs? + need ["docs"] + copyDirectory (root -/- "docs") bindistFilesDir -} + + -- We then 'need' all the files necessary to configure and install + -- (as in, './configure [...] && make install') this build on some + -- other machine. + need $ map (bindistFilesDir -/-) + (["configure", "Makefile"] ++ bindistInstallFiles) + need $ map ((bindistFilesDir -/- "wrappers") -/-) ["check-api-annotations" + , "check-ppr", "ghc", "ghc-iserv", "ghc-pkg", "ghc-split" + , "ghci-script", "ghci", "haddock", "hpc", "hp2ps", "hsc2hs" + , "runghc"] + + -- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz + command [Cwd $ root -/- "bindist"] "tar" + [ "-c", "--xz", "-f" + , ghcVersionPretty <.> "tar.xz" + , ghcVersionPretty ] + + -- Prepare binary distribution configure script + -- (generated under <ghc root>/distrib/configure by 'autoreconf') + root -/- "bindist" -/- "ghc-*" -/- "configure" %> \configurePath -> do + ghcRoot <- topDirectory + copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") + buildWithCmdOptions [] $ + target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] [] + -- We clean after ourselves, moving the configure script we generated in + -- our bindist dir + removeFile (ghcRoot -/- "distrib" -/- "aclocal.m4") + moveFile (ghcRoot -/- "distrib" -/- "configure") configurePath + + -- Generate the Makefile that enables the "make install" part + root -/- "bindist" -/- "ghc-*" -/- "Makefile" %> \makefilePath -> + writeFile' makefilePath bindistMakefile + + root -/- "bindist" -/- "ghc-*" -/- "wrappers/*" %> \wrapperPath -> + writeFile' wrapperPath $ wrapper (takeFileName wrapperPath) + + -- Copy various configure-related files needed for a working + -- './configure [...] && make install' workflow + -- (see the list of files needed in the 'binary-dist' rule above, before + -- creating the archive). + forM_ bindistInstallFiles $ \file -> + root -/- "bindist" -/- "ghc-*" -/- file %> \dest -> do + ghcRoot <- topDirectory + copyFile (ghcRoot -/- fixup file) dest + + where + fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f + | otherwise = f + +-- TODO: This list is surely incomplete -- fix this. +-- | A list of files that allow us to support a simple +-- @./configure [--prefix=PATH] && make install@ workflow. +bindistInstallFiles :: [FilePath] +bindistInstallFiles = + [ "config.sub", "config.guess", "install-sh", "mk" -/- "config.mk.in" + , "mk" -/- "install.mk.in", "mk" -/- "project.mk", "settings.in", "README" + , "INSTALL" ] + +-- | This auxiliary function gives us a top-level 'Filepath' that we can 'need' +-- for all libraries and programs that are needed for a complete build. +-- For libraries, it returns the path to the @.conf@ file in the package +-- database. For programs, it returns the path to the compiled executable. +pkgTarget :: Package -> Action FilePath +pkgTarget pkg + | isLibrary pkg = pkgConfFile (vanillaContext Stage1 pkg) + | otherwise = programPath =<< programContext Stage1 pkg + +-- TODO: Augment this Makefile to match the various parameters that the current +-- bindist scripts support. +-- | A trivial Makefile that only takes @$prefix@ into account, and not e.g +-- @$datadir@ (for docs) and other variables, yet. +bindistMakefile :: String +bindistMakefile = unlines + [ "MAKEFLAGS += --no-builtin-rules" + , ".SUFFIXES:" + , "" + , "include mk/install.mk" + , "include mk/config.mk" + , "" + , ".PHONY: default" + , "default:" + , "\t@echo 'Run \"make install\" to install'" + , "\t@false" + , "" + , "#------------------------------------------------------------------------------" + , "# INSTALL RULES" + , "" + , "# Hacky function to check equality of two strings" + , "# TODO : find if a better function exists" + , "eq=$(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))" + , "" + , "define installscript" + , "# $1 = package name" + , "# $2 = wrapper path" + , "# $3 = bindir" + , "# $4 = ghcbindir" + , "# $5 = Executable binary path" + , "# $6 = Library Directory" + , "# $7 = Docs Directory" + , "# $8 = Includes Directory" + , "# We are installing wrappers to programs by searching corresponding wrappers." + , "# If wrapper is not found, we are attaching the common wrapper to it " + , "# This implementation is a bit hacky and depends on consistency of program" + , "# names. For hadrian build this will work as programs have a consistent " + , "# naming procefure. This file is tested on Linux(Ubuntu)" + , "# TODO : Check implementation in other distributions" + , "\trm -f $2" + , "\t$(CREATE_SCRIPT) $2" + , "\t@echo \"#!$(SHELL)\" >> $2" + , "\t@echo \"exedir=\\\"$4\\\"\" >> $2" + , "\t@echo \"exeprog=\\\"$1\\\"\" >> $2" + , "\t@echo \"executablename=\\\"$5\\\"\" >> $2" + , "\t@echo \"bindir=\\\"$3\\\"\" >> $2" + , "\t@echo \"libdir=\\\"$6\\\"\" >> $2" + , "\t@echo \"docdir=\\\"$7\\\"\" >> $2" + , "\t@echo \"includedir=\\\"$8\\\"\" >> $2" + , "\t@echo \"\" >> $2 " + , "\tcat wrappers/$1 >> $2" + , "\t$(EXECUTABLE_FILE) $2 ;" + , "endef" + , "" + , "# QUESTION : should we use shell commands?" + , "" + , "# Due to the fact that package database is configured relatively" + , "# We do not change the relative paths of executables and libraries" + , "# But instead use wrapper scripts whenever necessary" + , "LIBPARENT = $(shell dirname $(libdir))" + , "GHCBINDIR = \"$(LIBPARENT)/bin\"" + , "" + , ".PHONY: install" + , "install: install_bin install_lib install_includes" + , "" + , "# Check if we need to install docs" + , "ifeq \"DOCS\" \"YES\"" + , "install: install_docs" + , "endif" + , "" + , "# If the relative path of binaries and libraries are altered, we will need to" + , "# install additional wrapper scripts at bindir." + , "ifneq \"$(LIBPARENT)/bin\" \"$(bindir)\"" + , "install: install_wrappers" + , "endif" + , "" + , "# We need to install binaries relative to libraries." + , "BINARIES = $(wildcard ./bin/*)" + , "install_bin:" + , "\t@echo \"Copying Binaries to $(GHCBINDIR)\"" + , "\t$(INSTALL_DIR) \"$(GHCBINDIR)\"" + , "\tfor i in $(BINARIES); do \\" + , "\t\tcp -R $$i \"$(GHCBINDIR)\"; \\" + , "\tdone" + , "\t@echo \"Copying and installing ghci\"" + , "\trm -f $(GHCBINDIR)/dir" + , "\t$(CREATE_SCRIPT) $(GHCBINDIR)/ghci" + , "\t@echo \"#!$(SHELL)\" >> $(GHCBINDIR)/ghci" + , "\tcat wrappers/ghci-script >> $(GHCBINDIR)/ghci" + , "\t$(EXECUTABLE_FILE) $(GHCBINDIR)/ghci" + , "" + , "LIBRARIES = $(wildcard ./lib/*)" + , "install_lib:" + , "\t@echo \"Copying libraries to $(libdir)\"" + , "\t$(INSTALL_DIR) \"$(libdir)\"" + , "\tfor i in $(LIBRARIES); do \\" + , "\t\tcp -R $$i \"$(libdir)/\"; \\" + , "\tdone" + , "" + , "INCLUDES = $(wildcard ./include/*)" + , "install_includes:" + , "\t@echo \"Copying libraries to $(includedir)\"" + , "\t$(INSTALL_DIR) \"$(includedir)\"" + , "\tfor i in $(INCLUDES); do \\" + , "\t\tcp -R $$i \"$(includedir)/\"; \\" + , "\tdone" + , "" + , "DOCS = $(wildcard ./docs/*)" + , "install_docs:" + , "\t@echo \"Copying libraries to $(docdir)\"" + , "\t$(INSTALL_DIR) \"$(docdir)\"" + , "\tfor i in $(DOCS); do \\" + , "\t\tcp -R $$i \"$(docdir)/\"; \\" + , "\tdone" + , "" + , "BINARY_NAMES=$(shell ls ./bin/)" + , "install_wrappers:" + , "\t@echo \"Installing Wrapper scripts\"" + , "\t$(INSTALL_DIR) \"$(bindir)\"" + , "\t$(foreach p, $(BINARY_NAMES),\\" + , "\t\t$(call installscript,$p,$(bindir)/$p,$(bindir),$(GHCBINDIR),$(GHCBINDIR)/$p,$(libdir),$(docdir),$(includedir)))" + , "" + , "# END INSTALL" + , "# -----------------------------------------------------------------------------" ] + +wrapper :: FilePath -> String +wrapper "ghc" = ghcWrapper +wrapper "ghc-pkg" = ghcPkgWrapper +wrapper "ghci" = ghciWrapper +wrapper "ghci-script" = ghciScriptWrapper +wrapper "haddock" = haddockWrapper +wrapper "hsc2hs" = hsc2hsWrapper +wrapper "runghc" = runGhcWrapper +wrapper _ = commonWrapper + +-- | Wrapper scripts for different programs. Common is default wrapper. + +ghcWrapper :: String +ghcWrapper = "exec \"$executablename\" -B\"$libdir\" ${1+\"$@\"}\n" + +ghcPkgWrapper :: String +ghcPkgWrapper = unlines + [ "PKGCONF=\"$libdir/package.conf.d\"" + , "exec \"$executablename\" --global-package-db \"$PKGCONF\" ${1+\"$@\"}" ] + +ghciWrapper :: String +ghciWrapper = "exec \"$executablename\" --interactive \"$@\"\n" + +haddockWrapper :: String +haddockWrapper = "exec \"$executablename\" -B\"$libdir\" -l\"$libdir\" ${1+\"$@\"}\n" + +commonWrapper :: String +commonWrapper = "exec \"$executablename\" ${1+\"$@\"}\n" + +hsc2hsWrapper :: String +hsc2hsWrapper = unlines + [ "HSC2HS_EXTRA=\"--cflag=-fno-stack-protector --lflag=-fuse-ld=gold\"" + , "tflag=\"--template=$libdir/template-hsc.h\"" + , "Iflag=\"-I$includedir/\"" + , "for arg do" + , " case \"$arg\" in" + , "# On OS X, we need to specify -m32 or -m64 in order to get gcc to" + , "# build binaries for the right target. We do that by putting it in" + , "# HSC2HS_EXTRA. When cabal runs hsc2hs, it passes a flag saying which" + , "# gcc to use, so if we set HSC2HS_EXTRA= then we don't get binaries" + , "# for the right platform. So for now we just don't set HSC2HS_EXTRA=" + , "# but we probably want to revisit how this works in the future." + , "# -c*) HSC2HS_EXTRA=;;" + , "# --cc=*) HSC2HS_EXTRA=;;" + , " -t*) tflag=;;" + , " --template=*) tflag=;;" + , " --) break;;" + , " esac" + , "done" + , "exec \"$executablename\" ${tflag:+\"$tflag\"} $HSC2HS_EXTRA ${1+\"$@\"} \"$Iflag\"" ] + +runGhcWrapper :: String +runGhcWrapper = "exec \"$executablename\" -f \"$exedir/ghc\" ${1+\"$@\"}\n" + +-- | We need to ship ghci executable, which basically just calls ghc with +-- | --interactive flag. +ghciScriptWrapper :: String +ghciScriptWrapper = unlines + [ "DIR=`dirname \"$0\"`" + , "executable=\"$DIR/ghc\"" + , "exec $executable --interactive \"$@\"" ] diff --git a/hadrian/src/Rules/Clean.hs b/hadrian/src/Rules/Clean.hs new file mode 100644 index 0000000000..abf6933b56 --- /dev/null +++ b/hadrian/src/Rules/Clean.hs @@ -0,0 +1,34 @@ +module Rules.Clean (clean, cleanSourceTree, cleanRules) where + +import qualified System.Directory as IO +import Base + +clean :: Action () +clean = do + putBuild "| Removing Hadrian files..." + cleanSourceTree + path <- buildRoot + putBuild $ "| Remove directory " ++ path ++ " (after build completes)" + runAfter $ IO.removeDirectoryRecursive path -- since we can't delete the Shake database while Shake is running + putSuccess "| Done. " + +cleanSourceTree :: Action () +cleanSourceTree = do + path <- buildRoot + forM_ [Stage0 ..] $ removeDirectory . (path -/-) . stageString + removeDirectory "sdistprep" + cleanFsUtils + +-- Clean all temporary fs files copied by configure into the source folder +cleanFsUtils :: Action () +cleanFsUtils = do + let dirs = [ "utils/lndir/" + , "utils/unlit/" + , "rts/" + , "libraries/base/include/" + , "libraries/base/cbits/" + ] + liftIO $ forM_ dirs (flip removeFiles ["fs.*"]) + +cleanRules :: Rules () +cleanRules = "clean" ~> clean diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs new file mode 100644 index 0000000000..4e85db2df6 --- /dev/null +++ b/hadrian/src/Rules/Compile.hs @@ -0,0 +1,83 @@ +module Rules.Compile (compilePackage) where + +import Hadrian.Oracles.TextFile + +import Base +import Context +import Expression +import Rules.Generate +import Target +import Utilities + +compilePackage :: [(Resource, Int)] -> Context -> Rules () +compilePackage rs context@Context {..} = do + root <- buildRootRules + let dir = root -/- buildDir context + nonHs extension = dir -/- extension <//> "*" <.> osuf way + compile compiler obj2src obj = do + src <- obj2src context obj + need [src] + needDependencies context src $ obj <.> "d" + buildWithResources rs $ target context (compiler stage) [src] [obj] + compileHs = \[obj, _hi] -> do + path <- contextPath context + (src, deps) <- lookupDependencies (path -/- ".dependencies") obj + need $ src : deps + needLibrary =<< contextDependencies context + buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj] + + priority 2.0 $ do + nonHs "c" %> compile (Ghc CompileCWithGhc) (obj2src "c" $ const False ) + nonHs "cmm" %> compile (Ghc CompileHs) (obj2src "cmm" isGeneratedCmmFile) + nonHs "s" %> compile (Ghc CompileHs) (obj2src "S" $ const False ) + + -- TODO: Add dependencies for #include of .h and .hs-incl files (gcc -MM?). + [ dir <//> "*" <.> suf way | suf <- [ osuf, hisuf] ] &%> compileHs + [ dir <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs + +-- | Discover dependencies of a given source file by iteratively calling @gcc@ +-- in the @-MM -MG@ mode and building generated dependencies if they are missing +-- until reaching a fixed point. +needDependencies :: Context -> FilePath -> FilePath -> Action () +needDependencies context@Context {..} src depFile = discover + where + discover = do + build $ target context (Cc FindCDependencies stage) [src] [depFile] + deps <- parseFile depFile + -- Generated dependencies, if not yet built, will not be found and hence + -- will be referred to simply by their file names. + let notFound = filter (\file -> file == takeFileName file) deps + -- We find the full paths to generated dependencies, so we can request + -- to build them by calling 'need'. + todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound + + if null todo + then need deps -- The list of dependencies is final, need all + else do + need todo -- Build newly discovered generated dependencies + discover -- Continue the discovery process + + parseFile :: FilePath -> Action [String] + parseFile file = do + input <- liftIO $ readFile file + case parseMakefile input of + [(_file, deps)] -> return deps + _ -> return [] + +-- | Find a given 'FilePath' in the list of generated files in the given +-- 'Context' and return its full path. +fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath) +fullPathIfGenerated context file = interpretInContext context $ do + generated <- generatedDependencies + return $ find ((== file) . takeFileName) generated + +obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> Action FilePath +obj2src extension isGenerated context@Context {..} obj + | isGenerated src = return src + | otherwise = (pkgPath package ++) <$> suffix + where + src = obj -<.> extension + suffix = do + path <- buildPath context + return $ fromMaybe ("Cannot determine source for " ++ obj) + $ stripPrefix (path -/- extension) src diff --git a/hadrian/src/Rules/Configure.hs b/hadrian/src/Rules/Configure.hs new file mode 100644 index 0000000000..909b3c3357 --- /dev/null +++ b/hadrian/src/Rules/Configure.hs @@ -0,0 +1,57 @@ +module Rules.Configure (configureRules) where + +import Base +import Builder +import CommandLine +import Context +import Packages +import Target +import Utilities + +import qualified System.Info.Extra as System + +-- TODO: Make this list complete. +-- | Files generated by running the @configure@ script. +configureResults :: [FilePath] +configureResults = + [ configFile, "settings", configH, "compiler/ghc.cabal", "rts/rts.cabal"] + +configureRules :: Rules () +configureRules = do + configureResults &%> \outs -> do + skip <- not <$> cmdConfigure + if skip + then unlessM (doesFileExist configFile) $ + error $ "Configuration file " ++ configFile ++ " is missing.\n" + ++ "Run the configure script manually or let Hadrian run it " + ++ "automatically by passing the flag --configure." + else do + -- We cannot use windowsHost here due to a cyclic dependency. + when System.isWindows $ do + putBuild "| Checking for Windows tarballs..." + quietly $ cmd ["bash", "mk/get-win32-tarballs.sh", "download", System.arch] + let srcs = map (<.> "in") outs + context = vanillaContext Stage0 compiler + need srcs + build $ target context (Configure ".") srcs outs + -- TODO: This is fragile: we should remove this from behind the + -- @--configure@ flag and add a proper dependency tracking. + -- We need to copy the directory with unpacked Windows tarball to + -- the build directory, so that the built GHC has access to it. + -- See https://github.com/snowleopard/hadrian/issues/564. + when System.isWindows $ do + root <- buildRoot + copyDirectory "inplace/mingw" (root -/- "mingw") + + ["configure", configH <.> "in"] &%> \_ -> do + skip <- not <$> cmdConfigure + if skip + then unlessM (doesFileExist "configure") $ + error $ "The configure script is missing.\nRun the boot script " + ++ "manually let Hadrian run it automatically by passing the " + ++ "flag --configure." + else do + need ["configure.ac"] + putBuild "| Running boot..." + verbosity <- getVerbosity + quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot --hadrian" diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs new file mode 100644 index 0000000000..9589d12aa0 --- /dev/null +++ b/hadrian/src/Rules/Dependencies.hs @@ -0,0 +1,35 @@ +module Rules.Dependencies (buildPackageDependencies) where + +import Data.Bifunctor +import Data.Function + +import Base +import Context +import Expression +import Oracles.ModuleFiles +import Rules.Generate +import Target +import Utilities + +buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules () +buildPackageDependencies rs context@Context {..} = do + root <- buildRootRules + root -/- contextDir context -/- ".dependencies.mk" %> \mk -> do + srcs <- hsSources context + need srcs + orderOnly =<< interpretInContext context generatedDependencies + if null srcs + then writeFileChanged mk "" + else buildWithResources rs $ + target context (Ghc FindHsDependencies stage) srcs [mk] + removeFile $ mk <.> "bak" + + root -/- contextDir context -/- ".dependencies" %> \deps -> do + mkDeps <- readFile' (deps <.> "mk") + writeFileChanged deps . unlines + . map (\(src, deps) -> unwords $ src : deps) + . map (bimap unifyPath (map unifyPath)) + . map (bimap head concat . unzip) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + $ parseMakefile mkDeps diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs new file mode 100644 index 0000000000..92b5ff5476 --- /dev/null +++ b/hadrian/src/Rules/Documentation.hs @@ -0,0 +1,210 @@ +module Rules.Documentation ( + -- * Rules + buildPackageDocumentation, documentationRules, + + -- * Utilities + haddockDependencies + ) where + +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type + +import Base +import Context +import Expression (getContextData, interpretInContext) +import Flavour +import Oracles.ModuleFiles +import Packages +import Settings +import Target +import Utilities + +docRoot :: FilePath +docRoot = "docs" + +htmlRoot :: FilePath +htmlRoot = docRoot -/- "html" + +pdfRoot :: FilePath +pdfRoot = docRoot -/- "pdfs" + +archiveRoot :: FilePath +archiveRoot = docRoot -/- "archives" + +haddockHtmlLib :: FilePath +haddockHtmlLib = htmlRoot -/- "haddock-bundle.min.js" + +manPageBuildPath :: FilePath +manPageBuildPath = "docs/users_guide/build-man/ghc.1" + +-- TODO: Get rid of this hack. +docContext :: Context +docContext = vanillaContext Stage2 (library "Documentation" "docs") + +docPaths :: [FilePath] +docPaths = ["libraries", "users_guide", "Haddock"] + +pathPdf :: FilePath -> FilePath +pathPdf path = pdfRoot -/- path <.> ".pdf" + +pathIndex :: FilePath -> FilePath +pathIndex path = htmlRoot -/- path -/- "index.html" + +pathArchive :: FilePath -> FilePath +pathArchive path = archiveRoot -/- path <.> "html.tar.xz" + +-- TODO: Get rid of this hack. +pathPath :: FilePath -> FilePath +pathPath "users_guide" = "docs/users_guide" +pathPath "Haddock" = "utils/haddock/doc" +pathPath _ = "" + +-- | Build all documentation +documentationRules :: Rules () +documentationRules = do + buildDocumentationArchives + buildHtmlDocumentation + buildManPage + buildPdfDocumentation + + "docs" ~> do + root <- buildRoot + let html = htmlRoot -/- "index.html" + archives = map pathArchive docPaths + pdfs = map pathPdf $ docPaths \\ ["libraries"] + need $ map (root -/-) $ [html] ++ archives ++ pdfs + need [ root -/- htmlRoot -/- "libraries" -/- "gen_contents_index" + , root -/- htmlRoot -/- "libraries" -/- "prologue.txt" + , root -/- manPageBuildPath ] + +------------------------------------- HTML ------------------------------------- + +-- | Build rules for HTML documentation. +buildHtmlDocumentation :: Rules () +buildHtmlDocumentation = do + mapM_ buildSphinxHtml $ docPaths \\ ["libraries"] + buildLibraryDocumentation + root <- buildRootRules + root -/- htmlRoot -/- "libraries/gen_contents_index" %> + copyFile "libraries/gen_contents_index" + + root -/- htmlRoot -/- "libraries/prologue.txt" %> + copyFile "libraries/prologue.txt" + + root -/- htmlRoot -/- "index.html" %> \file -> do + need [root -/- haddockHtmlLib] + need $ map ((root -/-) . pathIndex) docPaths + copyFileUntracked "docs/index.html" file + +-- | Compile a Sphinx ReStructured Text package to HTML. +buildSphinxHtml :: FilePath -> Rules () +buildSphinxHtml path = do + root <- buildRootRules + root -/- htmlRoot -/- path -/- "index.html" %> \file -> do + need [root -/- haddockHtmlLib] + let dest = takeDirectory file + build $ target docContext (Sphinx Html) [pathPath path] [dest] + +------------------------------------ Haddock ----------------------------------- + +-- | Build the haddocks for GHC's libraries. +buildLibraryDocumentation :: Rules () +buildLibraryDocumentation = do + root <- buildRootRules + + -- Js and Css files for haddock output + root -/- haddockHtmlLib %> \_ -> + copyDirectory "utils/haddock/haddock-api/resources/html" (root -/- docRoot) + + root -/- htmlRoot -/- "libraries/index.html" %> \file -> do + need [root -/- haddockHtmlLib] + haddocks <- allHaddocks + let libDocs = filter + (\x -> takeFileName x `notElem` ["ghc.haddock", "rts.haddock"]) + haddocks + need (root -/- haddockHtmlLib : libDocs) + build $ target docContext (Haddock BuildIndex) libDocs [file] + +allHaddocks :: Action [FilePath] +allHaddocks = do + pkgs <- stagePackages Stage1 + sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg + | pkg <- pkgs, isLibrary pkg ] + +-- Note: this build rule creates plenty of files, not just the .haddock one. +-- All of them go into the 'docRoot' subdirectory. Pedantically tracking all +-- built files in the Shake database seems fragile and unnecessary. +buildPackageDocumentation :: Context -> Rules () +buildPackageDocumentation context@Context {..} = when (stage == Stage1 && package /= rts) $ do + root <- buildRootRules + + -- Per-package haddocks + root -/- htmlRoot -/- "libraries" -/- pkgName package -/- "haddock-prologue.txt" %> \file -> do + need [root -/- haddockHtmlLib] + -- This is how @ghc-cabal@ used to produces "haddock-prologue.txt" files. + syn <- pkgSynopsis package + desc <- pkgDescription package + let prologue = if null desc then syn else desc + liftIO $ writeFile file prologue + + root -/- htmlRoot -/- "libraries" -/- pkgName package -/- pkgName package <.> "haddock" %> \file -> do + need [root -/- htmlRoot -/- "libraries" -/- pkgName package -/- "haddock-prologue.txt"] + haddocks <- haddockDependencies context + srcs <- hsSources context + need $ srcs ++ haddocks ++ [root -/- haddockHtmlLib] + + -- Build Haddock documentation + -- TODO: Pass the correct way from Rules via Context. + dynamicPrograms <- dynamicGhcPrograms =<< flavour + let haddockWay = if dynamicPrograms then dynamic else vanilla + build $ target (context {way = haddockWay}) (Haddock BuildPackage) srcs [file] + +-------------------------------------- PDF ------------------------------------- + +-- | Build all PDF documentation +buildPdfDocumentation :: Rules () +buildPdfDocumentation = mapM_ buildSphinxPdf docPaths + +-- | Compile a Sphinx ReStructured Text package to LaTeX +buildSphinxPdf :: FilePath -> Rules () +buildSphinxPdf path = do + root <- buildRootRules + root -/- pdfRoot -/- path <.> "pdf" %> \file -> do + need [root -/- haddockHtmlLib] + withTempDir $ \dir -> do + build $ target docContext (Sphinx Latex) [pathPath path] [dir] + build $ target docContext Xelatex [path <.> "tex"] [dir] + copyFileUntracked (dir -/- path <.> "pdf") file + +------------------------------------ Archive ----------------------------------- + +-- | Build documentation archives. +buildDocumentationArchives :: Rules () +buildDocumentationArchives = mapM_ buildArchive docPaths + +buildArchive :: FilePath -> Rules () +buildArchive path = do + root <- buildRootRules + root -/- pathArchive path %> \file -> do + need [root -/- haddockHtmlLib] + root <- buildRoot + let src = root -/- pathIndex path + need [src] + build $ target docContext (Tar Create) [takeDirectory src] [file] + +-- | Build the man page. +buildManPage :: Rules () +buildManPage = do + root <- buildRootRules + root -/- manPageBuildPath %> \file -> do + need [root -/- haddockHtmlLib, "docs/users_guide/ghc.rst"] + withTempDir $ \dir -> do + build $ target docContext (Sphinx Man) ["docs/users_guide"] [dir] + copyFileUntracked (dir -/- "ghc.1") file + +-- | Find the Haddock files for the dependencies of the current library. +haddockDependencies :: Context -> Action [FilePath] +haddockDependencies context = do + depNames <- interpretInContext context (getContextData depNames) + sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg + | Just depPkg <- map findPackageByName depNames, depPkg /= rts ] diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs new file mode 100644 index 0000000000..c3650c36b1 --- /dev/null +++ b/hadrian/src/Rules/Generate.hs @@ -0,0 +1,501 @@ +module Rules.Generate ( + isGeneratedCmmFile, generatePackageCode, generateRules, copyRules, + includesDependencies, generatedDependencies + ) where + +import Base +import Expression +import Flavour +import Oracles.Flag +import Oracles.ModuleFiles +import Oracles.Setting +import Packages +import Rules.Gmp +import Rules.Libffi +import Settings +import Target +import Utilities + +-- | Track this file to rebuild generated files whenever it changes. +trackGenerateHs :: Expr () +trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"] + +primopsSource :: FilePath +primopsSource = "compiler/prelude/primops.txt.pp" + +primopsTxt :: Stage -> FilePath +primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt" + +platformH :: Stage -> FilePath +platformH stage = buildDir (vanillaContext stage compiler) -/- "ghc_boot_platform.h" + +isGeneratedCmmFile :: FilePath -> Bool +isGeneratedCmmFile file = takeBaseName file == "AutoApply" + +includesDependencies :: [FilePath] +includesDependencies = fmap (generatedDir -/-) + [ "ghcautoconf.h" + , "ghcplatform.h" + , "ghcversion.h" ] + +ghcPrimDependencies :: Expr [FilePath] +ghcPrimDependencies = do + stage <- getStage + path <- expr $ buildPath (vanillaContext stage ghcPrim) + return [path -/- "GHC/Prim.hs", path -/- "GHC/PrimopWrappers.hs"] + +derivedConstantsDependencies :: [FilePath] +derivedConstantsDependencies = fmap (generatedDir -/-) + [ "DerivedConstants.h" + , "GHCConstantsHaskellExports.hs" + , "GHCConstantsHaskellType.hs" + , "GHCConstantsHaskellWrappers.hs" ] + +compilerDependencies :: Expr [FilePath] +compilerDependencies = do + root <- getBuildRoot + stage <- getStage + isGmp <- (== integerGmp) <$> getIntegerPackage + ghcPath <- expr $ buildPath (vanillaContext stage compiler) + gmpPath <- expr gmpBuildPath + rtsPath <- expr rtsBuildPath + mconcat [ return [root -/- platformH stage] + , return ((root -/-) <$> includesDependencies) + , return ((root -/-) <$> derivedConstantsDependencies) + , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH] + , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies) + , return $ fmap (ghcPath -/-) + [ "primop-can-fail.hs-incl" + , "primop-code-size.hs-incl" + , "primop-commutable.hs-incl" + , "primop-data-decl.hs-incl" + , "primop-fixity.hs-incl" + , "primop-has-side-effects.hs-incl" + , "primop-list.hs-incl" + , "primop-out-of-line.hs-incl" + , "primop-primop-info.hs-incl" + , "primop-strictness.hs-incl" + , "primop-tag.hs-incl" + , "primop-vector-tycons.hs-incl" + , "primop-vector-tys-exports.hs-incl" + , "primop-vector-tys.hs-incl" + , "primop-vector-uniques.hs-incl" ] ] + +generatedDependencies :: Expr [FilePath] +generatedDependencies = do + root <- getBuildRoot + rtsPath <- expr rtsBuildPath + mconcat [ package compiler ? compilerDependencies + , package ghcPrim ? ghcPrimDependencies + , package rts ? return (fmap (rtsPath -/-) libffiDependencies + ++ fmap (root -/-) includesDependencies + ++ fmap (root -/-) derivedConstantsDependencies) + , stage0 ? return (fmap (root -/-) includesDependencies) ] + +generate :: FilePath -> Context -> Expr String -> Action () +generate file context expr = do + contents <- interpretInContext context expr + writeFileChanged file contents + putSuccess $ "| Successfully generated " ++ file ++ "." + +generatePackageCode :: Context -> Rules () +generatePackageCode context@(Context stage pkg _) = do + root <- buildRootRules + let dir = buildDir context + generated f = (root -/- dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f) + go gen file = generate file context gen + generated ?> \file -> do + let unpack = fromMaybe . error $ "No generator for " ++ file ++ "." + (src, builder) <- unpack <$> findGenerator context file + need [src] + build $ target context builder [src] [file] + let boot = src -<.> "hs-boot" + whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot" + + priority 2.0 $ do + when (pkg == compiler) $ do root <//> dir -/- "Config.hs" %> go generateConfigHs + root <//> dir -/- "*.hs-incl" %> genPrimopCode context + when (pkg == ghcPrim) $ do (root <//> dir -/- "GHC/Prim.hs") %> genPrimopCode context + (root <//> dir -/- "GHC/PrimopWrappers.hs") %> genPrimopCode context + when (pkg == ghcPkg) $ do root <//> dir -/- "Version.hs" %> go generateVersionHs + + -- TODO: needing platformH is ugly and fragile + when (pkg == compiler) $ do + root -/- primopsTxt stage %> \file -> do + root <- buildRoot + need $ [ root -/- platformH stage + , primopsSource] + ++ fmap (root -/-) includesDependencies + build $ target context HsCpp [primopsSource] [file] + + -- only generate this once! Until we have the include logic fixed. + -- See the note on `platformH` + when (stage == Stage0) $ do + root <//> "compiler/ghc_boot_platform.h" %> go generateGhcBootPlatformH + root <//> platformH stage %> go generateGhcBootPlatformH + + when (pkg == rts) $ do + root <//> dir -/- "cmm/AutoApply.cmm" %> \file -> + build $ target context GenApply [] [file] + -- XXX: this should be fixed properly, e.g. generated here on demand. + (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir)) + (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir)) + (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir)) + (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir)) + when (pkg == integerGmp) $ do + (root <//> dir -/- "ghc-gmp.h") <~ (buildRoot <&> (-/- "include")) + where + pattern <~ mdir = pattern %> \file -> do + dir <- mdir + copyFile (dir -/- takeFileName file) file + +genPrimopCode :: Context -> FilePath -> Action () +genPrimopCode context@(Context stage _pkg _) file = do + root <- buildRoot + need [root -/- primopsTxt stage] + build $ target context GenPrimopCode [root -/- primopsTxt stage] [file] + +copyRules :: Rules () +copyRules = do + root <- buildRootRules + forM_ [Stage0 ..] $ \stage -> do + let prefix = root -/- stageString stage -/- "lib" + prefix -/- "ghc-usage.txt" <~ return "driver" + prefix -/- "ghci-usage.txt" <~ return "driver" + prefix -/- "llvm-targets" <~ return "." + prefix -/- "llvm-passes" <~ return "." + prefix -/- "platformConstants" <~ (buildRoot <&> (-/- generatedDir)) + prefix -/- "settings" <~ return "." + prefix -/- "template-hsc.h" <~ return (pkgPath hsc2hs) + where + infixl 1 <~ + pattern <~ mdir = pattern %> \file -> do + dir <- mdir + copyFile (dir -/- takeFileName file) file + +generateRules :: Rules () +generateRules = do + root <- buildRootRules + priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH + priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH + priority 2.0 $ (root -/- generatedDir -/- "ghcversion.h") <~ generateGhcVersionH + + forM_ [Stage0 ..] $ \stage -> + root -/- ghcSplitPath stage %> \path -> do + generate path emptyTarget generateGhcSplit + makeExecutable path + + -- TODO: simplify, get rid of fake rts context + root -/- generatedDir ++ "//*" %> \file -> do + withTempDir $ \dir -> build $ + target rtsContext DeriveConstants [] [file, dir] + where + file <~ gen = file %> \out -> generate out emptyTarget gen + +-- TODO: Use the Types, Luke! (drop partial function) +-- We sometimes need to evaluate expressions that do not require knowing all +-- information about the context. In this case, we don't want to know anything. +emptyTarget :: Context +emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage") + (error "Rules.Generate.emptyTarget: unknown package") + +-- Generators + +-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that +-- the resulting 'String' is a valid C preprocessor identifier. +cppify :: String -> String +cppify = replaceEq '-' '_' . replaceEq '.' '_' + +ghcSplitSource :: FilePath +ghcSplitSource = "driver/split/ghc-split.pl" + +-- ref: rules/build-perl.mk +-- | Generate the @ghc-split@ Perl script. +generateGhcSplit :: Expr String +generateGhcSplit = do + trackGenerateHs + targetPlatform <- getSetting TargetPlatform + ghcEnableTNC <- expr $ yesNo <$> ghcEnableTablesNextToCode + perlPath <- getBuilderPath Perl + contents <- expr $ readFileLines ghcSplitSource + return . unlines $ + [ "#!" ++ perlPath + , "my $TARGETPLATFORM = " ++ show targetPlatform ++ ";" + -- I don't see where the ghc-split tool uses TNC, but + -- it's in the build-perl macro. + , "my $TABLES_NEXT_TO_CODE = " ++ show ghcEnableTNC ++ ";" + ] ++ contents + +-- | Generate @ghcplatform.h@ header. +generateGhcPlatformH :: Expr String +generateGhcPlatformH = do + trackGenerateHs + hostPlatform <- getSetting HostPlatform + hostArch <- getSetting HostArch + hostOs <- getSetting HostOs + hostVendor <- getSetting HostVendor + targetPlatform <- getSetting TargetPlatform + targetArch <- getSetting TargetArch + targetOs <- getSetting TargetOs + targetVendor <- getSetting TargetVendor + ghcUnreg <- getFlag GhcUnregisterised + return . unlines $ + [ "#ifndef __GHCPLATFORM_H__" + , "#define __GHCPLATFORM_H__" + , "" + , "#define BuildPlatform_TYPE " ++ cppify hostPlatform + , "#define HostPlatform_TYPE " ++ cppify targetPlatform + , "" + , "#define " ++ cppify hostPlatform ++ "_BUILD 1" + , "#define " ++ cppify targetPlatform ++ "_HOST 1" + , "" + , "#define " ++ hostArch ++ "_BUILD_ARCH 1" + , "#define " ++ targetArch ++ "_HOST_ARCH 1" + , "#define BUILD_ARCH " ++ show hostArch + , "#define HOST_ARCH " ++ show targetArch + , "" + , "#define " ++ hostOs ++ "_BUILD_OS 1" + , "#define " ++ targetOs ++ "_HOST_OS 1" + , "#define BUILD_OS " ++ show hostOs + , "#define HOST_OS " ++ show targetOs + , "" + , "#define " ++ hostVendor ++ "_BUILD_VENDOR 1" + , "#define " ++ targetVendor ++ "_HOST_VENDOR 1" + , "#define BUILD_VENDOR " ++ show hostVendor + , "#define HOST_VENDOR " ++ show targetVendor + , "" + , "/* These TARGET macros are for backwards compatibility... DO NOT USE! */" + , "#define TargetPlatform_TYPE " ++ cppify targetPlatform + , "#define " ++ cppify targetPlatform ++ "_TARGET 1" + , "#define " ++ targetArch ++ "_TARGET_ARCH 1" + , "#define TARGET_ARCH " ++ show targetArch + , "#define " ++ targetOs ++ "_TARGET_OS 1" + , "#define TARGET_OS " ++ show targetOs + , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ] + ++ + [ "#define UnregisterisedCompiler 1" | ghcUnreg ] + ++ + [ "\n#endif /* __GHCPLATFORM_H__ */" ] + +-- | Generate @Config.hs@ files. +generateConfigHs :: Expr String +generateConfigHs = do + trackGenerateHs + cProjectName <- getSetting ProjectName + cProjectGitCommitId <- getSetting ProjectGitCommitId + cProjectVersion <- getSetting ProjectVersion + cProjectVersionInt <- getSetting ProjectVersionInt + cProjectPatchLevel <- getSetting ProjectPatchLevel + cProjectPatchLevel1 <- getSetting ProjectPatchLevel1 + cProjectPatchLevel2 <- getSetting ProjectPatchLevel2 + cBooterVersion <- getSetting GhcVersion + intLib <- getIntegerPackage + debugged <- ghcDebugged <$> expr flavour + let cIntegerLibraryType + | intLib == integerGmp = "IntegerGMP" + | intLib == integerSimple = "IntegerSimple" + | otherwise = error $ "Unknown integer library: " ++ pkgName intLib + cSupportsSplitObjs <- expr $ yesNo <$> supportsSplitObjects + cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter + cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen + cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP + cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode + cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore + cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit + cLibFFI <- expr useLibFFIForAdjustors + rtsWays <- getRtsWays + cGhcRtsWithLibdw <- getFlag WithLibdw + let cGhcRTSWays = unwords $ map show rtsWays + return $ unlines + [ "{-# LANGUAGE CPP #-}" + , "module Config where" + , "" + , "import GhcPrelude" + , "" + , "#include \"ghc_boot_platform.h\"" + , "" + , "data IntegerLibrary = IntegerGMP" + , " | IntegerSimple" + , " deriving Eq" + , "" + , "cBuildPlatformString :: String" + , "cBuildPlatformString = BuildPlatform_NAME" + , "cHostPlatformString :: String" + , "cHostPlatformString = HostPlatform_NAME" + , "cTargetPlatformString :: String" + , "cTargetPlatformString = TargetPlatform_NAME" + , "" + , "cProjectName :: String" + , "cProjectName = " ++ show cProjectName + , "cProjectGitCommitId :: String" + , "cProjectGitCommitId = " ++ show cProjectGitCommitId + , "cProjectVersion :: String" + , "cProjectVersion = " ++ show cProjectVersion + , "cProjectVersionInt :: String" + , "cProjectVersionInt = " ++ show cProjectVersionInt + , "cProjectPatchLevel :: String" + , "cProjectPatchLevel = " ++ show cProjectPatchLevel + , "cProjectPatchLevel1 :: String" + , "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1 + , "cProjectPatchLevel2 :: String" + , "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2 + , "cBooterVersion :: String" + , "cBooterVersion = " ++ show cBooterVersion + , "cStage :: String" + , "cStage = show (STAGE :: Int)" + , "cIntegerLibrary :: String" + , "cIntegerLibrary = " ++ show (pkgName intLib) + , "cIntegerLibraryType :: IntegerLibrary" + , "cIntegerLibraryType = " ++ cIntegerLibraryType + , "cSupportsSplitObjs :: String" + , "cSupportsSplitObjs = " ++ show cSupportsSplitObjs + , "cGhcWithInterpreter :: String" + , "cGhcWithInterpreter = " ++ show cGhcWithInterpreter + , "cGhcWithNativeCodeGen :: String" + , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen + , "cGhcWithSMP :: String" + , "cGhcWithSMP = " ++ show cGhcWithSMP + , "cGhcRTSWays :: String" + , "cGhcRTSWays = " ++ show cGhcRTSWays + , "cGhcEnableTablesNextToCode :: String" + , "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode + , "cLeadingUnderscore :: String" + , "cLeadingUnderscore = " ++ show cLeadingUnderscore + , "cGHC_UNLIT_PGM :: String" + , "cGHC_UNLIT_PGM = " ++ show cGHC_UNLIT_PGM + , "cGHC_SPLIT_PGM :: String" + , "cGHC_SPLIT_PGM = " ++ show "ghc-split" + , "cLibFFI :: Bool" + , "cLibFFI = " ++ show cLibFFI + , "cGhcThreaded :: Bool" + , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays) + , "cGhcDebugged :: Bool" + , "cGhcDebugged = " ++ show debugged + , "cGhcRtsWithLibdw :: Bool" + , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ] + +-- | Generate @ghcautoconf.h@ header. +generateGhcAutoconfH :: Expr String +generateGhcAutoconfH = do + trackGenerateHs + configHContents <- expr $ map undefinePackage <$> readFileLines configH + tablesNextToCode <- expr ghcEnableTablesNextToCode + ghcUnreg <- getFlag GhcUnregisterised + ccLlvmBackend <- getSetting CcLlvmBackend + ccClangBackend <- getSetting CcClangBackend + return . unlines $ + [ "#ifndef __GHCAUTOCONF_H__" + , "#define __GHCAUTOCONF_H__" ] + ++ configHContents ++ + [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ] + ++ + [ "\n#define llvm_CC_FLAVOR 1" | ccLlvmBackend == "1" ] + ++ + [ "\n#define clang_CC_FLAVOR 1" | ccClangBackend == "1" ] + ++ + [ "#endif /* __GHCAUTOCONF_H__ */" ] + where + undefinePackage s + | "#define PACKAGE_" `isPrefixOf` s + = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */" + | otherwise = s + +-- | Generate @ghc_boot_platform.h@ headers. +generateGhcBootPlatformH :: Expr String +generateGhcBootPlatformH = do + trackGenerateHs + stage <- getStage + let chooseSetting x y = getSetting $ if stage == Stage0 then x else y + buildPlatform <- chooseSetting BuildPlatform HostPlatform + buildArch <- chooseSetting BuildArch HostArch + buildOs <- chooseSetting BuildOs HostOs + buildVendor <- chooseSetting BuildVendor HostVendor + hostPlatform <- chooseSetting HostPlatform TargetPlatform + hostArch <- chooseSetting HostArch TargetArch + hostOs <- chooseSetting HostOs TargetOs + hostVendor <- chooseSetting HostVendor TargetVendor + targetPlatform <- getSetting TargetPlatform + targetArch <- getSetting TargetArch + llvmTarget <- getSetting LlvmTarget + targetOs <- getSetting TargetOs + targetVendor <- getSetting TargetVendor + return $ unlines + [ "#ifndef __PLATFORM_H__" + , "#define __PLATFORM_H__" + , "" + , "#define BuildPlatform_NAME " ++ show buildPlatform + , "#define HostPlatform_NAME " ++ show hostPlatform + , "#define TargetPlatform_NAME " ++ show targetPlatform + , "" + , "#define " ++ cppify buildPlatform ++ "_BUILD 1" + , "#define " ++ cppify hostPlatform ++ "_HOST 1" + , "#define " ++ cppify targetPlatform ++ "_TARGET 1" + , "" + , "#define " ++ buildArch ++ "_BUILD_ARCH 1" + , "#define " ++ hostArch ++ "_HOST_ARCH 1" + , "#define " ++ targetArch ++ "_TARGET_ARCH 1" + , "#define BUILD_ARCH " ++ show buildArch + , "#define HOST_ARCH " ++ show hostArch + , "#define TARGET_ARCH " ++ show targetArch + , "#define LLVM_TARGET " ++ show llvmTarget + , "" + , "#define " ++ buildOs ++ "_BUILD_OS 1" + , "#define " ++ hostOs ++ "_HOST_OS 1" + , "#define " ++ targetOs ++ "_TARGET_OS 1" + , "#define BUILD_OS " ++ show buildOs + , "#define HOST_OS " ++ show hostOs + , "#define TARGET_OS " ++ show targetOs + , "" + , "#define " ++ buildVendor ++ "_BUILD_VENDOR 1" + , "#define " ++ hostVendor ++ "_HOST_VENDOR 1" + , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" + , "#define BUILD_VENDOR " ++ show buildVendor + , "#define HOST_VENDOR " ++ show hostVendor + , "#define TARGET_VENDOR " ++ show targetVendor + , "" + , "#endif /* __PLATFORM_H__ */" ] + +-- | Generate @ghcversion.h@ header. +generateGhcVersionH :: Expr String +generateGhcVersionH = do + trackGenerateHs + version <- getSetting ProjectVersionInt + patchLevel1 <- getSetting ProjectPatchLevel1 + patchLevel2 <- getSetting ProjectPatchLevel2 + return . unlines $ + [ "#ifndef __GHCVERSION_H__" + , "#define __GHCVERSION_H__" + , "" + , "#ifndef __GLASGOW_HASKELL__" + , "# define __GLASGOW_HASKELL__ " ++ version + , "#endif" + , ""] + ++ + [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ] + ++ + [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ] + ++ + [ "" + , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\" + , " ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \\" + , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\" + , " && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \\" + , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\" + , " && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\" + , " && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )" + , "" + , "#endif /* __GHCVERSION_H__ */" ] + +-- | Generate @Version.hs@ files. +generateVersionHs :: Expr String +generateVersionHs = do + trackGenerateHs + projectVersion <- getSetting ProjectVersion + targetOs <- getSetting TargetOs + targetArch <- getSetting TargetArch + return $ unlines + [ "module Version where" + , "version, targetOS, targetARCH :: String" + , "version = " ++ show projectVersion + , "targetOS = " ++ show targetOs + , "targetARCH = " ++ show targetArch ] diff --git a/hadrian/src/Rules/Gmp.hs b/hadrian/src/Rules/Gmp.hs new file mode 100644 index 0000000000..32265fe401 --- /dev/null +++ b/hadrian/src/Rules/Gmp.hs @@ -0,0 +1,123 @@ +module Rules.Gmp ( + gmpRules, gmpBuildPath, gmpObjectsDir, gmpLibraryH + ) where + +import Base +import Context +import Oracles.Setting +import Packages +import Target +import Utilities + +gmpBase :: FilePath +gmpBase = pkgPath integerGmp -/- "gmp" + +gmpLibraryInTreeH :: FilePath +gmpLibraryInTreeH = "include/gmp.h" + +gmpLibrary :: FilePath +gmpLibrary = ".libs/libgmp.a" + +-- | GMP is considered a Stage1 package. This determines GMP build directory. +gmpContext :: Context +gmpContext = vanillaContext Stage1 integerGmp + +-- TODO: Location of 'gmpBuildPath' is important: it should be outside any +-- package build directory, as otherwise GMP's object files will match build +-- patterns of 'compilePackage' rules. We could make 'compilePackage' rules +-- more precise to avoid such spurious matching. +-- | Build directory for in-tree GMP library. +gmpBuildPath :: Action FilePath +gmpBuildPath = buildRoot <&> (-/- stageString (stage gmpContext) -/- "gmp") + +-- | GMP library header, relative to 'gmpBuildPath'. +gmpLibraryH :: FilePath +gmpLibraryH = "include/ghc-gmp.h" + +-- | Directory for GMP library object files, relative to 'gmpBuildPath'. +gmpObjectsDir :: FilePath +gmpObjectsDir = "objs" + +configureEnvironment :: Action [CmdOption] +configureEnvironment = sequence [ builderEnvironment "CC" $ Cc CompileC Stage1 + , builderEnvironment "AR" (Ar Unpack Stage1) + , builderEnvironment "NM" Nm ] + +gmpRules :: Rules () +gmpRules = do + -- Copy appropriate GMP header and object files + root <- buildRootRules + root <//> gmpLibraryH %> \header -> do + windows <- windowsHost + configMk <- readFile' =<< (buildPath gmpContext <&> (-/- "config.mk")) + if not windows && -- TODO: We don't use system GMP on Windows. Fix? + any (`isInfixOf` configMk) [ "HaveFrameworkGMP = YES", "HaveLibGmp = YES" ] + then do + putBuild "| GMP library/framework detected and will be used" + copyFile (gmpBase -/- "ghc-gmp.h") header + else do + putBuild "| No GMP library/framework detected; in tree GMP will be built" + gmpPath <- gmpBuildPath + need [gmpPath -/- gmpLibrary] + createDirectory (gmpPath -/- gmpObjectsDir) + top <- topDirectory + build $ target gmpContext (Ar Unpack Stage1) + [top -/- gmpPath -/- gmpLibrary] [gmpPath -/- gmpObjectsDir] + copyFile (gmpPath -/- "gmp.h") header + copyFile (gmpPath -/- "gmp.h") (gmpPath -/- gmpLibraryInTreeH) + + -- Build in-tree GMP library, prioritised so that it matches "before" + -- the generic .a library rule in Rules.Library, whenever applicable. + priority 2.0 $ root <//> gmpLibrary %> \lib -> do + gmpPath <- gmpBuildPath + build $ target gmpContext (Make gmpPath) [gmpPath -/- "Makefile"] [lib] + putSuccess "| Successfully built custom library 'gmp'" + + -- In-tree GMP header is built by the gmpLibraryH rule + root <//> gmpLibraryInTreeH %> \_ -> do + gmpPath <- gmpBuildPath + need [gmpPath -/- gmpLibraryH] + + -- This causes integerGmp package to be configured, hence creating the files + root <//> "gmp/config.mk" %> \_ -> do + -- Calling 'need' on @setup-config@ triggers 'configurePackage'. + -- TODO: Shall we run 'configurePackage' directly? Why this indirection? + setupConfig <- pkgSetupConfigFile gmpContext + need [setupConfig] + + -- TODO: Get rid of hard-coded @gmp@. + -- Run GMP's configure script + root <//> "gmp/Makefile" %> \mk -> do + env <- configureEnvironment + gmpPath <- gmpBuildPath + need [mk <.> "in"] + buildWithCmdOptions env $ + target gmpContext (Configure gmpPath) [mk <.> "in"] [mk] + + -- Extract in-tree GMP sources and apply patches + root <//> "gmp/Makefile.in" %> \_ -> do + gmpPath <- gmpBuildPath + removeDirectory gmpPath + -- Note: We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is + -- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents. + -- That's because the doc/ directory contents are under the GFDL, + -- which causes problems for Debian. + tarball <- unifyPath . fromSingleton "Exactly one GMP tarball is expected" + <$> getDirectoryFiles "" [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"] + + withTempDir $ \dir -> do + let tmp = unifyPath dir + need [tarball] + build $ target gmpContext (Tar Extract) [tarball] [tmp] + + let patch = gmpBase -/- "gmpsrc.patch" + patchName = takeFileName patch + copyFile patch $ tmp -/- patchName + applyPatch tmp patchName + + let name = dropExtension . dropExtension $ takeFileName tarball + unpack = fromMaybe . error $ "gmpRules: expected suffix " + ++ "-nodoc (found: " ++ name ++ ")." + libName = unpack $ stripSuffix "-nodoc" name + + moveDirectory (tmp -/- libName) gmpPath diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs new file mode 100644 index 0000000000..58ac1efbdc --- /dev/null +++ b/hadrian/src/Rules/Libffi.hs @@ -0,0 +1,109 @@ +module Rules.Libffi (libffiRules, libffiDependencies) where + +import Hadrian.Utilities + +import Packages +import Settings.Builders.Common +import Target +import Utilities + +libffiDependencies :: [FilePath] +libffiDependencies = ["ffi.h", "ffitarget.h"] + +libffiLibrary :: FilePath +libffiLibrary = "inst/lib/libffi.a" + +rtsLibffiLibrary :: Way -> Action FilePath +rtsLibffiLibrary way = do + name <- libffiLibraryName + suf <- libsuf way + rtsPath <- rtsBuildPath + return $ rtsPath -/- "lib" ++ name ++ suf + +fixLibffiMakefile :: FilePath -> String -> String +fixLibffiMakefile top = + replace "-MD" "-MMD" + . replace "@toolexeclibdir@" "$(libdir)" + . replace "@INSTALL@" ("$(subst ../install-sh," ++ top ++ "/install-sh,@INSTALL@)") + +-- TODO: check code duplication w.r.t. ConfCcArgs +configureEnvironment :: Action [CmdOption] +configureEnvironment = do + cFlags <- interpretInContext libffiContext $ mconcat + [ cArgs + , getStagedSettingList ConfCcArgs ] + ldFlags <- interpretInContext libffiContext ldArgs + sequence [ builderEnvironment "CC" $ Cc CompileC Stage1 + , builderEnvironment "CXX" $ Cc CompileC Stage1 + , builderEnvironment "LD" (Ld Stage1) + , builderEnvironment "AR" (Ar Unpack Stage1) + , builderEnvironment "NM" Nm + , builderEnvironment "RANLIB" Ranlib + , return . AddEnv "CFLAGS" $ unwords cFlags ++ " -w" + , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ] + +libffiRules :: Rules () +libffiRules = do + root <- buildRootRules + fmap ((root <//> "rts/build") -/-) libffiDependencies &%> \_ -> do + libffiPath <- libffiBuildPath + need [libffiPath -/- libffiLibrary] + + -- we set a higher priority because this overlaps + -- with the static lib rule from Rules.Library.libraryRules. + priority 2.0 $ root <//> libffiLibrary %> \_ -> do + useSystemFfi <- flag UseSystemFfi + rtsPath <- rtsBuildPath + if useSystemFfi + then do + ffiIncludeDir <- setting FfiIncludeDir + putBuild "| System supplied FFI library will be used" + forM_ ["ffi.h", "ffitarget.h"] $ \file -> + copyFile (ffiIncludeDir -/- file) (rtsPath -/- file) + putSuccess "| Successfully copied system FFI library header files" + else do + libffiPath <- libffiBuildPath + build $ target libffiContext (Make libffiPath) [] [] + + hs <- getDirectoryFiles "" [libffiPath -/- "inst/include/*"] + forM_ hs $ \header -> + copyFile header (rtsPath -/- takeFileName header) + + ways <- interpretInContext libffiContext (getLibraryWays <> getRtsWays) + forM_ (nubOrd ways) $ \way -> do + rtsLib <- rtsLibffiLibrary way + copyFileUntracked (libffiPath -/- libffiLibrary) rtsLib + + putSuccess "| Successfully built custom library 'libffi'" + + root <//> "libffi/build/Makefile.in" %> \mkIn -> do + libffiPath <- libffiBuildPath + removeDirectory libffiPath + tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected" + <$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"] + + need [tarball] + -- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999' + let libname = takeWhile (/= '+') $ takeFileName tarball + + root <- buildRoot + removeDirectory (root -/- libname) + -- TODO: Simplify. + actionFinally (do + build $ target libffiContext (Tar Extract) [tarball] [root] + moveDirectory (root -/- libname) libffiPath) $ + removeFiles root [libname <//> "*"] + + top <- topDirectory + fixFile mkIn (fixLibffiMakefile top) + + -- TODO: Get rid of hard-coded @libffi@. + root <//> "libffi/build/Makefile" %> \mk -> do + need [mk <.> "in"] + libffiPath <- libffiBuildPath + forM_ ["config.guess", "config.sub"] $ \file -> + copyFile file (libffiPath -/- file) + + env <- configureEnvironment + buildWithCmdOptions env $ + target libffiContext (Configure libffiPath) [mk <.> "in"] [mk] diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs new file mode 100644 index 0000000000..b53bcc8a8c --- /dev/null +++ b/hadrian/src/Rules/Library.hs @@ -0,0 +1,305 @@ +module Rules.Library (libraryRules) where + +import Data.Functor +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type +import qualified System.Directory as IO +import qualified Text.Parsec as Parsec + +import Base +import Context +import Expression hiding (way, package) +import Flavour +import Oracles.ModuleFiles +import Packages +import Rules.Gmp +import Settings +import Target +import Utilities + +-- * Library 'Rules' + +libraryRules :: Rules () +libraryRules = do + root <- buildRootRules + root -/- "//libHS*-*.dylib" %> buildDynamicLibUnix root "dylib" + root -/- "//libHS*-*.so" %> buildDynamicLibUnix root "so" + root -/- "//*.a" %> buildStaticLib root + priority 2 $ root -/- "//HS*-*.o" %> buildGhciLibO root + +-- * 'Action's for building libraries + +-- | Build a static library ('LibA') under the given build root, whose path is +-- the second argument. +buildStaticLib :: FilePath -> FilePath -> Action () +buildStaticLib root archivePath = do + l@(BuildPath _ stage _ (LibA pkgname _ way)) + <- parsePath (parseBuildLibA root) + "<.a library (build) path parser>" + archivePath + let context = libAContext l + objs <- libraryObjects context + removeFile archivePath + build $ target context (Ar Pack stage) objs [archivePath] + synopsis <- pkgSynopsis (package context) + putSuccess $ renderLibrary + (quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").") + archivePath synopsis + +-- | Build a dynamic library ('LibDyn') under the given build root, with the +-- given suffix (@.so@ or @.dylib@, @.dll@ in the future), where the complete +-- path of the archive to build is given as the third argument. +buildDynamicLibUnix :: FilePath -> String -> FilePath -> Action () +buildDynamicLibUnix root suffix dynlibpath = do + dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath + let context = libDynContext dynlib + deps <- contextDependencies context + need =<< mapM pkgLibraryFile deps + objs <- libraryObjects context + build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath] + +-- | Build a "GHCi library" ('LibGhci') under the given build root, with the +-- complete path of the file to build is given as the second argument. +buildGhciLibO :: FilePath -> FilePath -> Action () +buildGhciLibO root ghcilibPath = do + l@(BuildPath _ stage _ (LibGhci _ _ _)) + <- parsePath (parseBuildLibGhci root) + "<.o ghci lib (build) path parser>" + ghcilibPath + let context = libGhciContext l + objs <- allObjects context + need objs + build $ target context (Ld stage) objs [ghcilibPath] + +-- * Helpers + +-- | Return all Haskell and non-Haskell object files for the given 'Context'. +allObjects :: Context -> Action [FilePath] +allObjects context = (++) <$> nonHsObjects context <*> hsObjects context + +-- | Return all the non-Haskell object files for the given library context +-- (object files built from C, C-- and sometimes other things). +nonHsObjects :: Context -> Action [FilePath] +nonHsObjects context = do + cObjs <- cObjects context + cmmSrcs <- interpretInContext context (getContextData cmmSrcs) + cmmObjs <- mapM (objectPath context) cmmSrcs + eObjs <- extraObjects context + return $ cObjs ++ cmmObjs ++ eObjs + +-- | Return all the C object files needed to build the given library context. +cObjects :: Context -> Action [FilePath] +cObjects context = do + srcs <- interpretInContext context (getContextData cSrcs) + objs <- mapM (objectPath context) srcs + return $ if Threaded `wayUnit` way context + then objs + else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs + +-- | Return extra object files needed to build the given library context. The +-- resulting list is currently non-empty only when the package from the +-- 'Context' is @integer-gmp@. +extraObjects :: Context -> Action [FilePath] +extraObjects context + | package context == integerGmp = do + gmpPath <- gmpBuildPath + need [gmpPath -/- gmpLibraryH] + map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"] + | otherwise = return [] + +-- | Return all the object files to be put into the library we're building for +-- the given 'Context'. +libraryObjects :: Context -> Action [FilePath] +libraryObjects context@Context{..} = do + hsObjs <- hsObjects context + noHsObjs <- nonHsObjects context + + -- This will create split objects if required (we don't track them + -- explicitly as this would needlessly bloat the Shake database). + need $ noHsObjs ++ hsObjs + + split <- interpretInContext context =<< splitObjects <$> flavour + let getSplitObjs = concatForM hsObjs $ \obj -> do + let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split" + contents <- liftIO $ IO.getDirectoryContents dir + return . map (dir -/-) $ filter (not . all (== '.')) contents + + (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs + +-- * Library paths types and parsers + +-- | > libHS<pkg name>-<pkg version>[_<way suffix>].a +data LibA = LibA String [Integer] Way deriving (Eq, Show) + +-- | > <so or dylib> +data DynLibExt = So | Dylib deriving (Eq, Show) + +-- | > libHS<pkg name>-<pkg version>-ghc<ghc version>[_<way suffix>].<so or dylib> +data LibDyn = LibDyn String [Integer] Way DynLibExt deriving (Eq, Show) + +-- | > HS<pkg name>-<pkg version>[_<way suffix>].o +data LibGhci = LibGhci String [Integer] Way deriving (Eq, Show) + +-- | A path of the form +-- +-- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something> +-- +-- where @something@ describes a library to be build for the given package. +-- +-- @a@, which represents that @something@, is instantiated as 'LibA', 'LibDyn' +-- and 'LibGhci' successively in this module, depending on the type of library +-- we're giving the build rules for. +data BuildPath a = BuildPath FilePath -- ^ > <build root>/ + Stage -- ^ > stage<N>/ + FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/ + a -- ^ > whatever comes after 'build/' + deriving (Eq, Show) + +-- | Get the 'Context' corresponding to the build path for a given static library. +libAContext :: BuildPath LibA -> Context +libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way)) = + Context stage pkg way + where + pkg = library pkgname pkgpath + +-- | Get the 'Context' corresponding to the build path for a given GHCi library. +libGhciContext :: BuildPath LibGhci -> Context +libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way)) = + Context stage pkg way + where + pkg = library pkgname pkgpath + +-- | Get the 'Context' corresponding to the build path for a given dynamic library. +libDynContext :: BuildPath LibDyn -> Context +libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _)) = + Context stage pkg way + where + pkg = library pkgname pkgpath + +-- | Parse a build path for a library to be built under the given build root, +-- where the filename will be parsed with the given parser argument. +parseBuildPath + :: FilePath -- ^ build root + -> Parsec.Parsec String () a -- ^ what to parse after @build/@ + -> Parsec.Parsec String () (BuildPath a) +parseBuildPath root afterBuild = do + _ <- Parsec.string root *> Parsec.optional (Parsec.char '/') + stage <- parseStage + _ <- Parsec.char '/' + pkgpath <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/build/") + a <- afterBuild + return (BuildPath root stage pkgpath a) + +-- | Parse a path to a static library to be built, making sure the path starts +-- with the given build root. +parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA) +parseBuildLibA root = parseBuildPath root parseLibAFilename + Parsec.<?> "build path for a static library" + +-- | Parse a path to a ghci library to be built, making sure the path starts +-- with the given build root. +parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci) +parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename + Parsec.<?> "build path for a ghci library" + +-- | Parse a path to a dynamic library to be built, making sure the path starts +-- with the given build root. +parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn) +parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext) + Parsec.<?> ("build path for a dynamic library with extension " ++ ext) + +-- | Parse the filename of a static library to be built into a 'LibA' value. +parseLibAFilename :: Parsec.Parsec String () LibA +parseLibAFilename = do + _ <- Parsec.string "libHS" + (pkgname, pkgver) <- parsePkgId + way <- parseWaySuffix vanilla + _ <- Parsec.string ".a" + return (LibA pkgname pkgver way) + +-- | Parse the filename of a ghci library to be built into a 'LibGhci' value. +parseLibGhciFilename :: Parsec.Parsec String () LibGhci +parseLibGhciFilename = do + _ <- Parsec.string "HS" + (pkgname, pkgver) <- parsePkgId + way <- parseWaySuffix vanilla + _ <- Parsec.string ".o" + return (LibGhci pkgname pkgver way) + +-- | Parse the filename of a dynamic library to be built into a 'LibDyn' value. +parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn +parseLibDynFilename ext = do + _ <- Parsec.string "libHS" + (pkgname, pkgver) <- parsePkgId + _ <- optional $ Parsec.string "-ghc" *> parsePkgVersion + way <- addWayUnit Dynamic <$> parseWaySuffix dynamic + _ <- Parsec.string ("." ++ ext) + return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib) + +-- To be kept in sync with Stage.hs's stageString function +-- | Parse @"stageX"@ into a 'Stage'. +parseStage :: Parsec.Parsec String () Stage +parseStage = (Parsec.string "stage" *> Parsec.choice + [ Parsec.string (show n) $> toEnum n + | n <- map fromEnum [minBound .. maxBound :: Stage] + ]) Parsec.<?> "stage string" + +-- To be kept in sync with the show instances in 'Way.Type', until we perhaps +-- use some bidirectional parsing/pretty printing approach or library. +-- | Parse a way suffix, returning the argument when no suffix is found (the +-- argument will be vanilla in most cases, but dynamic when we parse the way +-- suffix out of a shared library file name). +parseWaySuffix :: Way -> Parsec.Parsec String () Way +parseWaySuffix w = Parsec.choice + [ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_")) + , pure w + ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)" + where + parseWayUnit = Parsec.choice + [ Parsec.string "thr" *> pure Threaded + , Parsec.char 'd' *> + (Parsec.choice [ Parsec.string "ebug" *> pure Debug + , Parsec.string "yn" *> pure Dynamic ]) + , Parsec.char 'p' *> pure Profiling + , Parsec.char 'l' *> pure Logging + ] Parsec.<?> "way unit (thr, debug, dyn, p, l)" + +-- | Parse a @"pkgname-pkgversion"@ string into the package name and the +-- integers that make up the package version. +parsePkgId :: Parsec.Parsec String () (String, [Integer]) +parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)" + where + parsePkgId' currName = do + s <- Parsec.many1 Parsec.alphaNum + _ <- Parsec.char '-' + let newName = if null currName then s else currName ++ "-" ++ s + Parsec.choice [ (newName,) <$> parsePkgVersion + , parsePkgId' newName ] + +-- | Parse "."-separated integers that describe a package's version. +parsePkgVersion :: Parsec.Parsec String () [Integer] +parsePkgVersion = fmap reverse (parsePkgVersion' []) Parsec.<?> "package version" + where + parsePkgVersion' xs = do + n <- parseNatural + Parsec.choice + [ Parsec.try (Parsec.lookAhead (Parsec.char '.' *> (Parsec.letter <|> Parsec.char '_'))) + $> (n:xs) + , Parsec.char '.' *> parsePkgVersion' (n:xs) + , pure $ (n:xs) ] + +-- | Parse a natural number. +parseNatural :: Parsec.Parsec String () Integer +parseNatural = (read <$> Parsec.many1 Parsec.digit) Parsec.<?> "natural number" + +-- | Runs the given parser against the given path, erroring out when the parser +-- fails (because it shouldn't if the code from this module is correct). +parsePath + :: Parsec.Parsec String () a -- ^ parser to run + -> String -- ^ string describing the input source + -> FilePath -- ^ path to parse + -> Action a +parsePath p inp path = case Parsec.parse p inp path of + Left err -> fail $ "Rules.Library.parsePath: path=" + ++ path ++ ", error:\n" ++ show err + Right a -> pure a diff --git a/hadrian/src/Rules/Nofib.hs b/hadrian/src/Rules/Nofib.hs new file mode 100644 index 0000000000..0950605199 --- /dev/null +++ b/hadrian/src/Rules/Nofib.hs @@ -0,0 +1,57 @@ +module Rules.Nofib where + +import Base +import Expression +import Oracles.Setting +import Packages + +import System.Environment +import System.Exit + +nofibLogFile :: FilePath +nofibLogFile = "nofib-log" + +-- | Rules for running the @nofib@ benchmark suite. +nofibRules :: Rules () +nofibRules = do + root <- buildRootRules + + -- a phony "nofib" rule that just triggers + -- the rule below. + "nofib" ~> need [root -/- nofibLogFile] + + -- a rule to produce <build root>/nofig-log + -- by running the nofib suite and capturing + -- the relevant output. + root -/- nofibLogFile %> \fp -> do + needNofibDeps + + makePath <- builderPath (Make "nofib") + top <- topDirectory + ghcPath <- builderPath (Ghc CompileHs Stage2) + perlPath <- builderPath Perl + + -- some makefiles in nofib rely on a $MAKE + -- env var being defined + liftIO (setEnv "MAKE" makePath) + + -- this runs make commands in the nofib + -- subdirectory, passing the path to + -- the GHC to benchmark and perl to + -- nofib's makefiles. + let nofibArgs = ["WithNofibHc=" ++ (top -/- ghcPath), "PERL=" ++ perlPath] + unit $ cmd (Cwd "nofib") [makePath] ["clean"] + unit $ cmd (Cwd "nofib") [makePath] (nofibArgs ++ ["boot"]) + (Exit e, Stdouterr log) <- cmd (Cwd "nofib") [makePath] nofibArgs + writeFile' fp log + if e == ExitSuccess + then putLoud $ "nofib log available at " ++ fp + else error $ "nofib failed, full log available at " ++ fp + +-- | Build the dependencies required by @nofib@. +needNofibDeps :: Action () +needNofibDeps = do + unlitPath <- programPath (vanillaContext Stage1 unlit) + mtlPath <- pkgConfFile (vanillaContext Stage1 mtl ) + need [ unlitPath, mtlPath ] + needBuilder (Ghc CompileHs Stage2) diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs new file mode 100644 index 0000000000..f5be21a2e3 --- /dev/null +++ b/hadrian/src/Rules/Program.hs @@ -0,0 +1,77 @@ +module Rules.Program (buildProgram) where + +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type + +import Base +import Context +import Expression hiding (stage, way) +import Oracles.Flag +import Oracles.ModuleFiles +import Packages +import Settings +import Settings.Default +import Target +import Utilities + +-- | TODO: Drop code duplication +buildProgram :: [(Resource, Int)] -> Rules () +buildProgram rs = do + root <- buildRootRules + forM_ [Stage0 ..] $ \stage -> + [ root -/- stageString stage -/- "bin" -/- "*" + , root -/- stageString stage -/- "lib/bin" -/- "*" ] |%> \bin -> do + -- This is quite inefficient, but we can't access 'programName' from + -- 'Rules', because it is an 'Action' depending on an oracle. + sPackages <- filter isProgram <$> stagePackages stage + tPackages <- testsuitePackages + -- TODO: Shall we use Stage2 for testsuite packages instead? + let allPackages = sPackages + ++ if stage == Stage1 then tPackages else [] + nameToCtxList <- forM allPackages $ \pkg -> do + let ctx = vanillaContext stage pkg + name <- programName ctx + return (name <.> exe, ctx) + + case lookup (takeFileName bin) nameToCtxList of + Nothing -> error $ "Unknown program " ++ show bin + Just (Context {..}) -> do + -- Custom dependencies: this should be modeled better in the + -- Cabal file somehow. + -- TODO: Is this still needed? See 'runtimeDependencies'. + when (package == hsc2hs) $ do + -- 'Hsc2hs' needs the @template-hsc.h@ file. + template <- templateHscPath stage + need [template] + when (package == ghc) $ do + -- GHC depends on @settings@, @platformConstants@, + -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@, + -- @llvm-passes@. + need =<< ghcDeps stage + + cross <- flag CrossCompiling + -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@. + case (cross, stage) of + (True, s) | s > Stage0 -> do + srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin")) + copyFile (srcDir -/- takeFileName bin) bin + (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do + srcDir <- stageLibPath Stage0 <&> (-/- "bin") + copyFile (srcDir -/- takeFileName bin) bin + _ -> buildBinary rs bin =<< programContext stage package + +buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action () +buildBinary rs bin context@Context {..} = do + needLibrary =<< contextDependencies context + when (stage > Stage0) $ do + ways <- interpretInContext context (getLibraryWays <> getRtsWays) + needLibrary [ rtsContext { way = w } | w <- ways ] + cSrcs <- interpretInContext context (getContextData cSrcs) + cObjs <- mapM (objectPath context) cSrcs + hsObjs <- hsObjects context + let binDeps = cObjs ++ hsObjs + need binDeps + buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin] + synopsis <- pkgSynopsis package + putSuccess $ renderProgram + (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs new file mode 100644 index 0000000000..62023d72e4 --- /dev/null +++ b/hadrian/src/Rules/Register.hs @@ -0,0 +1,103 @@ +module Rules.Register (configurePackage, registerPackage) where + +import Distribution.ParseUtils +import Distribution.Version (Version) +import qualified Distribution.Compat.ReadP as Parse +import qualified Hadrian.Haskell.Cabal.Parse as Cabal +import Hadrian.Expression +import qualified System.Directory as IO + +import Base +import Context +import Packages +import Settings +import Target +import Utilities + +parseCabalName :: String -> Maybe (String, Version) +parseCabalName = readPToMaybe parse + where + parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion + +-- | Configure a package and build its @setup-config@ file. +configurePackage :: Context -> Rules () +configurePackage context@Context {..} = do + root <- buildRootRules + root -/- contextDir context -/- "setup-config" %> \_ -> + Cabal.configurePackage context + +-- | Register a package and initialise the corresponding package database if +-- need be. Note that we only register packages in 'Stage0' and 'Stage1'. +registerPackage :: [(Resource, Int)] -> Context -> Rules () +registerPackage rs context@Context {..} = when (stage < Stage2) $ do + root <- buildRootRules + + -- Initialise the package database. + root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp -> + writeFileLines stamp [] + + -- TODO: Add proper error handling for partial functions. + -- Register a package. + root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do + settings <- libPath context <&> (-/- "settings") + platformConstants <- libPath context <&> (-/- "platformConstants") + need [settings, platformConstants] + let Just pkgName | takeBaseName conf == "rts" = Just "rts" + | otherwise = fst <$> parseCabalName (takeBaseName conf) + let Just pkg = findPackageByName pkgName + isBoot <- (pkg `notElem`) <$> stagePackages Stage0 + case stage of + Stage0 | isBoot -> copyConf rs (context { package = pkg }) conf + _ -> buildConf rs (context { package = pkg }) conf + +buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action () +buildConf _ context@Context {..} _conf = do + depPkgIds <- cabalDependencies context + + -- Calling 'need' on @setupConfig@, triggers the package configuration. + setupConfig <- pkgSetupConfigFile context + need [setupConfig] + need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds + + ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty) + need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ] + + -- We might need some package-db resource to limit read/write, see packageRules. + path <- buildPath context + + -- Special package cases (these should ideally be rolled into Cabal). + when (package == rts) $ + -- If Cabal knew about "generated-headers", we could read them from the + -- 'configuredCabal' information, and just "need" them here. + need [ path -/- "DerivedConstants.h" + , path -/- "ghcautoconf.h" + , path -/- "ghcplatform.h" + , path -/- "ghcversion.h" + , path -/- "ffi.h" ] + + when (package == integerGmp) $ need [path -/- "ghc-gmp.h"] + + -- Copy and register the package. + Cabal.copyPackage context + Cabal.registerPackage context + +copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action () +copyConf rs context@Context {..} conf = do + depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $ + target context (GhcPkg Dependencies stage) [pkgName package] [] + need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds + -- We should unregister if the file exists since @ghc-pkg@ will complain + -- about existing package: https://github.com/snowleopard/hadrian/issues/543. + -- Also, we don't always do the unregistration + registration to avoid + -- repeated work after a full build. + -- We do not track 'doesFileExist' since we are going to create the file if + -- it is currently missing. TODO: Is this the right thing to do? + -- See https://github.com/snowleopard/hadrian/issues/569. + unlessM (liftIO $ IO.doesFileExist conf) $ do + buildWithResources rs $ + target context (GhcPkg Unregister stage) [pkgName package] [] + buildWithResources rs $ + target context (GhcPkg Copy stage) [pkgName package] [conf] + where + stdOutToPkgIds :: String -> [String] + stdOutToPkgIds = drop 1 . concatMap words . lines diff --git a/hadrian/src/Rules/Selftest.hs b/hadrian/src/Rules/Selftest.hs new file mode 100644 index 0000000000..68aa6e3889 --- /dev/null +++ b/hadrian/src/Rules/Selftest.hs @@ -0,0 +1,113 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Rules.Selftest (selftestRules) where + +import Hadrian.Haskell.Cabal +import Test.QuickCheck + +import Base +import Context +import Oracles.ModuleFiles +import Oracles.Setting +import Packages +import Settings +import Target +import Utilities + +instance Arbitrary Way where + arbitrary = wayFromUnits <$> arbitrary + +instance Arbitrary WayUnit where + arbitrary = arbitraryBoundedEnum + +test :: Testable a => a -> Action () +test = liftIO . quickCheck + +selftestRules :: Rules () +selftestRules = + "selftest" ~> do + testBuilder + testChunksOfSize + testDependencies + testLookupAll + testModuleName + testPackages + testWay + +testBuilder :: Action () +testBuilder = do + putBuild "==== trackArgument" + let make = target undefined (Make undefined) undefined undefined + test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="]) + $ \prefix (NonNegative n) -> + not (trackArgument make prefix) && + not (trackArgument make ("-j" ++ show (n :: Int))) + +testChunksOfSize :: Action () +testChunksOfSize = do + putBuild "==== chunksOfSize" + test $ chunksOfSize 3 [ "a", "b", "c" , "defg" , "hi" , "jk" ] + == [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ] + test $ \n xs -> + let res = chunksOfSize n xs + in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res + +testDependencies :: Action () +testDependencies = do + putBuild "==== pkgDependencies" + let pkgs = ghcPackages \\ [libffi] -- @libffi@ does not have a Cabal file. + depLists <- mapM pkgDependencies pkgs + test $ and [ deps == sort deps | deps <- depLists ] + putBuild "==== Dependencies of the 'ghc-bin' binary" + ghcDeps <- pkgDependencies ghc + test $ pkgName compiler `elem` ghcDeps + stage0Deps <- contextDependencies (vanillaContext Stage0 ghc) + stage1Deps <- contextDependencies (vanillaContext Stage1 ghc) + stage2Deps <- contextDependencies (vanillaContext Stage2 ghc) + test $ vanillaContext Stage0 compiler `notElem` stage1Deps + test $ vanillaContext Stage1 compiler `elem` stage1Deps + test $ vanillaContext Stage2 compiler `notElem` stage1Deps + test $ stage1Deps /= stage0Deps + test $ stage1Deps == stage2Deps + +testLookupAll :: Action () +testLookupAll = do + putBuild "==== lookupAll" + test $ lookupAll ["b" , "c" ] [("a", 1), ("c", 3), ("d", 4)] + == [Nothing, Just (3 :: Int)] + test $ forAll dicts $ \dict -> forAll extras $ \extra -> + let items = sort $ map fst dict ++ extra + in lookupAll items (sort dict) == map (`lookup` dict) items + where + dicts :: Gen [(Int, Int)] + dicts = nubBy (\x y -> fst x == fst y) <$> vector 20 + extras :: Gen [Int] + extras = vector 20 + +testModuleName :: Action () +testModuleName = do + putBuild "==== Encode/decode module name" + test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity" + test $ encodeModule "" "Prelude" == "Prelude" + + test $ decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity") + test $ decodeModule "Prelude" == ("", "Prelude") + + test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n + where + names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'") + +testPackages :: Action () +testPackages = do + putBuild "==== Check system configuration" + win <- windowsHost -- This depends on the @boot@ and @configure@ scripts. + putBuild "==== Packages, interpretInContext, configuration flags" + forM_ [Stage0 ..] $ \stage -> do + pkgs <- stagePackages stage + when (win32 `elem` pkgs) . test $ win + when (unix `elem` pkgs) . test $ not win + test $ pkgs == nubOrd pkgs + +testWay :: Action () +testWay = do + putBuild "==== Read Way, Show Way" + test $ \(x :: Way) -> read (show x) == x diff --git a/hadrian/src/Rules/SourceDist.hs b/hadrian/src/Rules/SourceDist.hs new file mode 100644 index 0000000000..8bec3f3b26 --- /dev/null +++ b/hadrian/src/Rules/SourceDist.hs @@ -0,0 +1,114 @@ +module Rules.SourceDist (sourceDistRules) where + +import Hadrian.Oracles.DirectoryContents + +import Base +import Builder +import Oracles.Setting +import Rules.Clean + +sourceDistRules :: Rules () +sourceDistRules = do + "source-dist" ~> do + -- We clean the source tree first. + -- See https://github.com/snowleopard/hadrian/issues/384. + -- TODO: Do we still need to clean the tree? + cleanSourceTree + version <- setting ProjectVersion + need ["sdistprep/ghc-" ++ version ++ "-src.tar.xz"] + putSuccess "| Done" + "sdistprep/ghc-*-src.tar.xz" %> \fname -> do + let tarName = takeFileName fname + dropTarXz = dropExtension . dropExtension + treePath = "sdistprep/ghc" -/- dropTarXz tarName + prepareTree treePath + runBuilderWithCmdOptions [Cwd "sdistprep/ghc"] (Tar Create) + ["cJf", ".." -/- tarName, dropTarXz tarName] + ["cJf", ".." -/- tarName] [dropTarXz tarName] + "GIT_COMMIT_ID" %> \fname -> + writeFileChanged fname =<< setting ProjectGitCommitId + "VERSION" %> \fname -> + writeFileChanged fname =<< setting ProjectVersion + +prepareTree :: FilePath -> Action () +prepareTree dest = do + mapM_ cpDir srcDirs + mapM_ cpFile srcFiles + where + cpFile a = copyFile a (dest -/- a) + cpDir a = copyDirectoryContents (Not excluded) a (dest -/- a) + excluded = Or + [ Test "//.*" + , Test "//#*" + , Test "//*-SAVE" + , Test "//*.orig" + , Test "//*.rej" + , Test "//*~" + , Test "//autom4te*" + , Test "//dist" + , Test "//dist-install" + , Test "//log" + , Test "//stage0" + , Test "//stage1" + , Test "//stage2" + , Test "//stage3" + , Test "hadrian/.cabal-sandbox" + , Test "hadrian/.stack-work" + , Test "hadrian/UserSettings.hs" + , Test "hadrian/cabal.sandbox.config" + , Test "hadrian/cfg/system.config" + , Test "hadrian/bin" + , Test "hadrian/dist" + , Test "hadrian/dist-newstyle" + , Test "libraries//*.buildinfo" + , Test "libraries//GNUmakefile" + , Test "libraries//config.log" + , Test "libraries//config.status" + , Test "libraries//configure" + , Test "libraries//ghc.mk" + , Test "libraries//include/Hs*Config.h" + , Test "libraries/dph" + , Test "libraries/parallel" + , Test "libraries/primitive" + , Test "libraries/random" + , Test "libraries/stm" + , Test "libraries/vector" + , Test "mk/build.mk" ] + srcDirs = + [ "bindisttest" + , "compiler" + , "distrib" + , "docs" + , "docs" + , "driver" + , "ghc" + , "hadrian" + , "includes" + , "iserv" + , "libffi" + , "libffi-tarballs" + , "libraries" + , "mk" + , "rts" + , "rules" + , "utils" ] + srcFiles = + [ "ANNOUNCE" + , "GIT_COMMIT_ID" + , "HACKING.md" + , "INSTALL.md" + , "LICENSE" + , "MAKEHELP.md" + , "Makefile" + , "README.md" + , "VERSION" + , "aclocal.m4" + , "boot" + , "config.guess" + , "config.sub" + , "configure" + , "configure.ac" + , "ghc.mk" + , "install-sh" + , "packages" + , "settings.in" ] diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs new file mode 100644 index 0000000000..f5d6990e69 --- /dev/null +++ b/hadrian/src/Rules/Test.hs @@ -0,0 +1,124 @@ +module Rules.Test (testRules) where + +import System.Environment + +import Base +import Expression +import Oracles.Setting +import Packages +import Settings +import Settings.Default +import Settings.Builders.RunTest +import Target +import Utilities + +ghcConfigHsPath :: FilePath +ghcConfigHsPath = "testsuite/mk/ghc-config.hs" + +ghcConfigProgPath :: FilePath +ghcConfigProgPath = "test/bin/ghc-config" + +ghcConfigPath :: FilePath +ghcConfigPath = "test/ghcconfig" + +-- TODO: clean up after testing +testRules :: Rules () +testRules = do + root <- buildRootRules + + -- | Using program shipped with testsuite to generate ghcconfig file. + root -/- ghcConfigProgPath ~> do + ghc <- builderPath $ Ghc CompileHs Stage0 + createDirectory $ takeDirectory (root -/- ghcConfigProgPath) + cmd ghc [ghcConfigHsPath, "-o" , root -/- ghcConfigProgPath] + + -- | TODO : Use input test compiler and not just stage2 compiler. + root -/- ghcConfigPath ~> do + ghcPath <- needFile Stage1 ghc + need [root -/- ghcConfigProgPath] + cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath) + [ghcPath] + + root -/- timeoutPath ~> timeoutProgBuilder + + "validate" ~> do + needTestBuilders + build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] [] + + "test" ~> do + needTestBuilders + + -- TODO : Should we remove the previosly generated config file? + -- Prepare Ghc configuration file for input compiler. + need [root -/- ghcConfigPath, root -/- timeoutPath] + + -- TODO This approach doesn't work. + -- Set environment variables for test's Makefile. + env <- sequence + [ builderEnvironment "MAKE" $ Make "" + , builderEnvironment "TEST_HC" $ Ghc CompileHs Stage2 + , AddEnv "TEST_HC_OPTS" <$> runTestGhcFlags ] + + makePath <- builderPath $ Make "" + top <- topDirectory + ghcPath <- (top -/-) <$> builderPath (Ghc CompileHs Stage2) + ghcFlags <- runTestGhcFlags + checkPprPath <- (top -/-) <$> needFile Stage1 checkPpr + annotationsPath <- (top -/-) <$> needFile Stage1 checkApiAnnotations + + -- Set environment variables for test's Makefile. + liftIO $ do + setEnv "MAKE" makePath + setEnv "TEST_HC" ghcPath + setEnv "TEST_HC_OPTS" ghcFlags + setEnv "CHECK_PPR" checkPprPath + setEnv "CHECK_API_ANNOTATIONS" annotationsPath + + -- Execute the test target. + buildWithCmdOptions env $ target (vanillaContext Stage2 compiler) RunTest [] [] + +-- | Build extra programs and libraries required by testsuite +needTestsuitePackages :: Action () +needTestsuitePackages = do + targets <- mapM (needFile Stage1) =<< testsuitePackages + libPath <- stageLibPath Stage1 + iservPath <- needFile Stage1 iserv + need targets + -- | We need to copy iserv bin to lib/bin as this is where testsuite looks + -- | for iserv. + copyFile iservPath $ libPath -/- "bin/ghc-iserv" + +-- | Build the timeout program. +-- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23 +timeoutProgBuilder :: Action () +timeoutProgBuilder = do + root <- buildRoot + windows <- windowsHost + if windows + then do + prog <- programPath =<< programContext Stage1 timeout + copyFile prog (root -/- timeoutPath) + else do + python <- builderPath Python + copyFile "testsuite/timeout/timeout.py" (root -/- timeoutPath <.> "py") + let script = unlines + [ "#!/usr/bin/env sh" + , "exec " ++ python ++ " $0.py \"$@\"" ] + writeFile' (root -/- timeoutPath) script + makeExecutable (root -/- timeoutPath) + +needTestBuilders :: Action () +needTestBuilders = do + needBuilder $ Ghc CompileHs Stage2 + needBuilder $ GhcPkg Update Stage1 + needBuilder Hpc + needBuilder $ Hsc2Hs Stage1 + needTestsuitePackages + +needFile :: Stage -> Package -> Action FilePath +needFile stage pkg +-- TODO (Alp): we might sometimes need more than vanilla! +-- This should therefore depend on what test ways +-- we are going to use, I suppose? + | isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic) + | otherwise = programPath =<< programContext stage pkg diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs new file mode 100755 index 0000000000..3497f43a1e --- /dev/null +++ b/hadrian/src/Settings.hs @@ -0,0 +1,66 @@ +module Settings ( + getArgs, getLibraryWays, getRtsWays, flavour, knownPackages, + findPackageByName, isLibrary, stagePackages, programContext, + getIntegerPackage + ) where + +import CommandLine +import Expression +import Flavour +import Packages +import UserSettings + +import {-# SOURCE #-} Settings.Default +import Settings.Flavours.Development +import Settings.Flavours.Performance +import Settings.Flavours.Profiled +import Settings.Flavours.Quick +import Settings.Flavours.Quickest +import Settings.Flavours.QuickCross + +getArgs :: Args +getArgs = expr flavour >>= args + +getLibraryWays :: Ways +getLibraryWays = expr flavour >>= libraryWays + +getRtsWays :: Ways +getRtsWays = expr flavour >>= rtsWays + +stagePackages :: Stage -> Action [Package] +stagePackages stage = do + f <- flavour + packages f stage + +hadrianFlavours :: [Flavour] +hadrianFlavours = + [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2 + , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour + , quickCrossFlavour ] + +flavour :: Action Flavour +flavour = do + flavourName <- fromMaybe "default" <$> cmdFlavour + let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName + flavours = hadrianFlavours ++ userFlavours + return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours + +getIntegerPackage :: Expr Package +getIntegerPackage = expr (integerLibrary =<< flavour) + +programContext :: Stage -> Package -> Action Context +programContext stage pkg = do + profiled <- ghcProfiled <$> flavour + return $ if pkg == ghc && profiled && stage > Stage0 + then Context stage pkg profiling + else vanillaContext stage pkg + +-- TODO: switch to Set Package as the order of packages should not matter? +-- Otherwise we have to keep remembering to sort packages from time to time. +knownPackages :: [Package] +knownPackages = sort $ ghcPackages ++ userPackages + +-- TODO: Speed up? Switch to Set? +-- Note: this is slow but we keep it simple as there are just ~50 packages +findPackageByName :: PackageName -> Maybe Package +findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages diff --git a/hadrian/src/Settings/Builders/Alex.hs b/hadrian/src/Settings/Builders/Alex.hs new file mode 100644 index 0000000000..e0ef1367f7 --- /dev/null +++ b/hadrian/src/Settings/Builders/Alex.hs @@ -0,0 +1,8 @@ +module Settings.Builders.Alex (alexBuilderArgs) where + +import Settings.Builders.Common + +alexBuilderArgs :: Args +alexBuilderArgs = builder Alex ? mconcat [ arg "-g" + , arg =<< getInput + , arg "-o", arg =<< getOutput ] diff --git a/hadrian/src/Settings/Builders/Cabal.hs b/hadrian/src/Settings/Builders/Cabal.hs new file mode 100644 index 0000000000..f33e9b458c --- /dev/null +++ b/hadrian/src/Settings/Builders/Cabal.hs @@ -0,0 +1,153 @@ +module Settings.Builders.Cabal (cabalBuilderArgs) where + +import Hadrian.Builder (getBuilderPath, needBuilder) +import Hadrian.Haskell.Cabal + +import Builder +import Context +import Flavour +import Packages +import Settings.Builders.Common + +cabalBuilderArgs :: Args +cabalBuilderArgs = builder (Cabal Setup) ? do + verbosity <- expr getVerbosity + top <- expr topDirectory + path <- getContextPath + stage <- getStage + mconcat [ arg "configure" + -- Don't strip libraries when cross compiling. + -- TODO: We need to set @--with-strip=(stripCmdPath :: Action FilePath)@, + -- and if it's @:@ disable stripping as well. As it is now, I believe + -- we might have issues with stripping on Windows, as I can't see a + -- consumer of 'stripCmdPath'. + -- TODO: See https://github.com/snowleopard/hadrian/issues/549. + , flag CrossCompiling ? pure [ "--disable-executable-stripping" + , "--disable-library-stripping" ] + , arg "--cabal-file" + , arg =<< pkgCabalFile <$> getPackage + , arg "--distdir" + , arg $ top -/- path + , arg "--ipid" + , arg "$pkg-$version" + , arg "--prefix" + , arg "${pkgroot}/.." + , withStaged $ Ghc CompileHs + , withStaged (GhcPkg Update) + , withBuilderArgs (GhcPkg Update stage) + , bootPackageDatabaseArgs + , libraryArgs + , configureArgs + , bootPackageConstraints + , withStaged $ Cc CompileC + , notStage0 ? with (Ld stage) + , withStaged (Ar Pack) + , with Alex + , with Happy + , verbosity < Chatty ? + pure [ "-v0", "--configure-option=--quiet" + , "--configure-option=--disable-option-checking" ] ] + +-- TODO: Isn't vanilla always built? If yes, some conditions are redundant. +-- TODO: Need compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci? +-- TODO: should `elem` be `wayUnit`? +-- This approach still doesn't work. Previously libraries were build only in the +-- Default flavours and not using context. +libraryArgs :: Args +libraryArgs = do + flavourWays <- getLibraryWays + contextWay <- getWay + withGhci <- expr ghcWithInterpreter + dynPrograms <- expr (flavour >>= dynamicGhcPrograms) + let ways = flavourWays ++ [contextWay] + pure [ if vanilla `elem` ways + then "--enable-library-vanilla" + else "--disable-library-vanilla" + , if vanilla `elem` ways && withGhci && not dynPrograms + then "--enable-library-for-ghci" + else "--disable-library-for-ghci" + , if or [Profiling `wayUnit` way | way <- ways] + then "--enable-library-profiling" + else "--disable-library-profiling" + , if or [Dynamic `wayUnit` way | way <- ways] + then "--enable-shared" + else "--disable-shared" ] + +-- TODO: LD_OPTS? +configureArgs :: Args +configureArgs = do + top <- expr topDirectory + root <- getBuildRoot + pkg <- getPackage + let conf key expr = do + values <- unwords <$> expr + not (null values) ? + arg ("--configure-option=" ++ key ++ "=" ++ values) + cFlags = mconcat [ remove ["-Werror"] cArgs + , getStagedSettingList ConfCcArgs + , arg $ "-I" ++ top -/- root -/- generatedDir + -- See https://github.com/snowleopard/hadrian/issues/523 + , arg $ "-I" ++ top -/- pkgPath pkg + , arg $ "-I" ++ top -/- "includes" ] + ldFlags = ldArgs <> (getStagedSettingList ConfGccLinkerArgs) + cppFlags = cppArgs <> (getStagedSettingList ConfCppArgs) + cldFlags <- unwords <$> (cFlags <> ldFlags) + mconcat + [ conf "CFLAGS" cFlags + , conf "LDFLAGS" ldFlags + , conf "CPPFLAGS" cppFlags + , not (null cldFlags) ? arg ("--gcc-options=" ++ cldFlags) + , conf "--with-iconv-includes" $ arg =<< getSetting IconvIncludeDir + , conf "--with-iconv-libraries" $ arg =<< getSetting IconvLibDir + , conf "--with-gmp-includes" $ arg =<< getSetting GmpIncludeDir + , conf "--with-gmp-libraries" $ arg =<< getSetting GmpLibDir + , conf "--with-curses-libraries" $ arg =<< getSetting CursesLibDir + , flag CrossCompiling ? (conf "--host" $ arg =<< getSetting TargetPlatformFull) + , conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage + , notStage0 ? (arg =<< ("--ghc-option=-ghcversion-file=" ++) <$> expr ((-/-) <$> topDirectory <*> ghcVersionH))] + +bootPackageConstraints :: Args +bootPackageConstraints = stage0 ? do + bootPkgs <- expr $ stagePackages Stage0 + let pkgs = filter (\p -> p /= compiler && isLibrary p) bootPkgs + constraints <- expr $ forM (sort pkgs) $ \pkg -> do + version <- pkgVersion pkg + return $ ((pkgName pkg ++ " == ") ++) version + pure $ concat [ ["--constraint", c] | c <- constraints ] + +cppArgs :: Args +cppArgs = do + root <- getBuildRoot + arg $ "-I" ++ root -/- generatedDir + +withBuilderKey :: Builder -> String +withBuilderKey b = case b of + Ar _ _ -> "--with-ar=" + Ld _ -> "--with-ld=" + Cc _ _ -> "--with-gcc=" + Ghc _ _ -> "--with-ghc=" + Alex -> "--with-alex=" + Happy -> "--with-happy=" + GhcPkg _ _ -> "--with-ghc-pkg=" + _ -> error $ "withBuilderKey: not supported builder " ++ show b + +-- | Add arguments to builders if needed. +withBuilderArgs :: Builder -> Args +withBuilderArgs b = case b of + GhcPkg _ stage -> do + top <- expr topDirectory + pkgDb <- expr $ packageDbPath stage + notStage0 ? arg ("--ghc-pkg-option=--global-package-db=" ++ top -/- pkgDb) + _ -> return [] -- no arguments + +-- | Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex. +with :: Builder -> Args +with b = do + path <- getBuilderPath b + if null path then mempty else do + top <- expr topDirectory + expr $ needBuilder b + arg $ withBuilderKey b ++ unifyPath (top </> path) + +withStaged :: (Stage -> Builder) -> Args +withStaged sb = with . sb =<< getStage diff --git a/hadrian/src/Settings/Builders/Cc.hs b/hadrian/src/Settings/Builders/Cc.hs new file mode 100644 index 0000000000..e0055f3e8b --- /dev/null +++ b/hadrian/src/Settings/Builders/Cc.hs @@ -0,0 +1,28 @@ +module Settings.Builders.Cc (ccBuilderArgs) where + +import Hadrian.Haskell.Cabal.Type +import Settings.Builders.Common + +ccBuilderArgs :: Args +ccBuilderArgs = do + way <- getWay + builder Cc ? mconcat + [ getContextData ccOpts + , getStagedSettingList ConfCcArgs + + , builder (Cc CompileC) ? mconcat + [ arg "-Wall" + , cIncludeArgs + , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ] + , arg "-c", arg =<< getInput + , arg "-o", arg =<< getOutput ] + + , builder (Cc FindCDependencies) ? do + output <- getOutput + mconcat [ arg "-E" + , arg "-MM", arg "-MG" + , arg "-MF", arg output + , arg "-MT", arg $ dropExtension output -<.> "o" + , cIncludeArgs + , arg "-x", arg "c" + , arg =<< getInput ] ] diff --git a/hadrian/src/Settings/Builders/Common.hs b/hadrian/src/Settings/Builders/Common.hs new file mode 100644 index 0000000000..6846c4bc8d --- /dev/null +++ b/hadrian/src/Settings/Builders/Common.hs @@ -0,0 +1,73 @@ +module Settings.Builders.Common ( + module Base, + module Expression, + module Oracles.Flag, + module Oracles.Setting, + module Settings, + module UserSettings, + cIncludeArgs, ldArgs, cArgs, cWarnings, + packageDatabaseArgs, bootPackageDatabaseArgs + ) where + +import Hadrian.Haskell.Cabal.Type + +import Base +import Expression +import Oracles.Flag +import Oracles.Setting +import Packages +import Settings +import UserSettings + +cIncludeArgs :: Args +cIncludeArgs = do + pkg <- getPackage + root <- getBuildRoot + path <- getBuildPath + incDirs <- getContextData includeDirs + depDirs <- getContextData depIncludeDirs + iconvIncludeDir <- getSetting IconvIncludeDir + gmpIncludeDir <- getSetting GmpIncludeDir + ffiIncludeDir <- getSetting FfiIncludeDir + mconcat [ notStage0 ||^ package compiler ? arg "-Iincludes" + , arg $ "-I" ++ root -/- generatedDir + , arg $ "-I" ++ path + , pure . map ("-I"++) . filter (/= "") $ [iconvIncludeDir, gmpIncludeDir] + , flag UseSystemFfi ? arg ("-I" ++ ffiIncludeDir) + -- Add @incDirs@ in the build directory, since some files generated + -- with @autoconf@ may end up in the build directory. + , pure [ "-I" ++ path -/- dir | dir <- incDirs ] + -- Add @incDirs@ in the package directory for include files shipped + -- with the package. + , pure [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ] + , pure [ "-I" ++ unifyPath dir | dir <- depDirs ] ] + +ldArgs :: Args +ldArgs = mempty + +cArgs :: Args +cArgs = mempty + +-- TODO: should be in a different file +cWarnings :: Args +cWarnings = mconcat + [ arg "-Wall" + , flag GccIsClang ? arg "-Wno-unknown-pragmas" + , notM (flag GccIsClang) ? notM windowsHost ? arg "-Werror=unused-but-set-variable" + , notM (flag GccIsClang) ? arg "-Wno-error=inline" ] + +packageDatabaseArgs :: Args +packageDatabaseArgs = do + stage <- getStage + dbPath <- expr (packageDbPath stage) + expr (need [dbPath -/- packageDbStamp]) + root <- getBuildRoot + prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=") + arg $ prefix ++ root -/- relativePackageDbPath stage + +bootPackageDatabaseArgs :: Args +bootPackageDatabaseArgs = do + stage <- getStage + dbPath <- expr $ packageDbPath stage + expr $ need [dbPath -/- packageDbStamp] + stage0 ? packageDatabaseArgs diff --git a/hadrian/src/Settings/Builders/Configure.hs b/hadrian/src/Settings/Builders/Configure.hs new file mode 100644 index 0000000000..068591dfbb --- /dev/null +++ b/hadrian/src/Settings/Builders/Configure.hs @@ -0,0 +1,25 @@ +module Settings.Builders.Configure (configureBuilderArgs) where + +import Packages +import Rules.Gmp +import Settings.Builders.Common + +configureBuilderArgs :: Args +configureBuilderArgs = do + gmpPath <- expr gmpBuildPath + libffiPath <- expr libffiBuildPath + mconcat [ builder (Configure gmpPath) ? do + hostPlatform <- getSetting HostPlatform + buildPlatform <- getSetting BuildPlatform + pure [ "--enable-shared=no" + , "--host=" ++ hostPlatform + , "--build=" ++ buildPlatform ] + + , builder (Configure libffiPath) ? do + top <- expr topDirectory + targetPlatform <- getSetting TargetPlatform + pure [ "--prefix=" ++ top -/- libffiPath -/- "inst" + , "--libdir=" ++ top -/- libffiPath -/- "inst/lib" + , "--enable-static=yes" + , "--enable-shared=no" -- TODO: add support for yes + , "--host=" ++ targetPlatform ] ] diff --git a/hadrian/src/Settings/Builders/DeriveConstants.hs b/hadrian/src/Settings/Builders/DeriveConstants.hs new file mode 100644 index 0000000000..bd7511be23 --- /dev/null +++ b/hadrian/src/Settings/Builders/DeriveConstants.hs @@ -0,0 +1,40 @@ +module Settings.Builders.DeriveConstants (deriveConstantsBuilderArgs) where + +import Builder +import Settings.Builders.Common + +-- TODO: do we need to support `includes_CC_OPTS += -DDYNAMIC_BY_DEFAULT`? +deriveConstantsBuilderArgs :: Args +deriveConstantsBuilderArgs = builder DeriveConstants ? do + cFlags <- includeCcArgs + outs <- getOutputs + let (outputFile, tempDir) = case outs of + [a, b] -> (a, b) + _ -> error $ "DeriveConstants: expected two outputs, got " ++ show outs + mconcat + [ output "//DerivedConstants.h" ? arg "--gen-header" + , output "//GHCConstantsHaskellType.hs" ? arg "--gen-haskell-type" + , output "//platformConstants" ? arg "--gen-haskell-value" + , output "//GHCConstantsHaskellWrappers.hs" ? arg "--gen-haskell-wrappers" + , output "//GHCConstantsHaskellExports.hs" ? arg "--gen-haskell-exports" + , arg "-o", arg outputFile + , arg "--tmpdir", arg tempDir + , arg "--gcc-program", arg =<< getBuilderPath (Cc CompileC Stage1) + , pure $ concatMap (\a -> ["--gcc-flag", a]) cFlags + , arg "--nm-program", arg =<< getBuilderPath Nm + , isSpecified Objdump ? mconcat [ arg "--objdump-program" + , arg =<< getBuilderPath Objdump ] + , arg "--target-os", arg =<< getSetting TargetOs ] + +includeCcArgs :: Args +includeCcArgs = do + root <- getBuildRoot + mconcat [ cArgs + , cWarnings + , getSettingList $ ConfCcArgs Stage1 + , flag GhcUnregisterised ? arg "-DUSE_MINIINTERPRETER" + , arg "-Irts" + , arg "-Iincludes" + , arg $ "-I" ++ root -/- generatedDir + , notM ghcWithSMP ? arg "-DNOSMP" + , arg "-fcommon" ] diff --git a/hadrian/src/Settings/Builders/GenPrimopCode.hs b/hadrian/src/Settings/Builders/GenPrimopCode.hs new file mode 100644 index 0000000000..e616ed3b43 --- /dev/null +++ b/hadrian/src/Settings/Builders/GenPrimopCode.hs @@ -0,0 +1,24 @@ +module Settings.Builders.GenPrimopCode (genPrimopCodeBuilderArgs) where + +import Settings.Builders.Common + +genPrimopCodeBuilderArgs :: Args +genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat + [ output "//PrimopWrappers.hs" ? arg "--make-haskell-wrappers" + , output "//Prim.hs" ? arg "--make-haskell-source" + , output "//primop-data-decl.hs-incl" ? arg "--data-decl" + , output "//primop-tag.hs-incl" ? arg "--primop-tag" + , output "//primop-list.hs-incl" ? arg "--primop-list" + , output "//primop-has-side-effects.hs-incl" ? arg "--has-side-effects" + , output "//primop-out-of-line.hs-incl" ? arg "--out-of-line" + , output "//primop-commutable.hs-incl" ? arg "--commutable" + , output "//primop-code-size.hs-incl" ? arg "--code-size" + , output "//primop-can-fail.hs-incl" ? arg "--can-fail" + , output "//primop-strictness.hs-incl" ? arg "--strictness" + , output "//primop-fixity.hs-incl" ? arg "--fixity" + , output "//primop-primop-info.hs-incl" ? arg "--primop-primop-info" + , output "//primop-vector-uniques.hs-incl" ? arg "--primop-vector-uniques" + , output "//primop-vector-tys.hs-incl" ? arg "--primop-vector-tys" + , output "//primop-vector-tys-exports.hs-incl" ? arg "--primop-vector-tys-exports" + , output "//primop-vector-tycons.hs-incl" ? arg "--primop-vector-tycons" + , output "//primop-usage.hs-incl" ? arg "--usage" ] diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs new file mode 100644 index 0000000000..8212b5fbcf --- /dev/null +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -0,0 +1,134 @@ +module Settings.Builders.Ghc (ghcBuilderArgs, haddockGhcArgs) where + +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type + +import Flavour +import Packages +import Settings.Builders.Common +import Settings.Warnings + +ghcBuilderArgs :: Args +ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies] + +compileAndLinkHs :: Args +compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do + mconcat [ arg "-Wall" + , commonGhcArgs + , splitObjects <$> flavour ? arg "-split-objs" + , ghcLinkArgs + , defaultGhcWarningsArgs + , builder (Ghc CompileHs) ? arg "-c" + , getInputs + , arg "-o", arg =<< getOutput ] + +compileC :: Args +compileC = builder (Ghc CompileCWithGhc) ? do + way <- getWay + let ccArgs = [ getContextData ccOpts + , getStagedSettingList ConfCcArgs + , cIncludeArgs + , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ] ] + mconcat [ arg "-Wall" + , ghcLinkArgs + , commonGhcArgs + , mconcat (map (map ("-optc" ++) <$>) ccArgs) + , defaultGhcWarningsArgs + , arg "-c" + , getInputs + , arg "-o" + , arg =<< getOutput ] + +ghcLinkArgs :: Args +ghcLinkArgs = builder (Ghc LinkHs) ? do + way <- getWay + pkg <- getPackage + libs <- pkg == hp2ps ? pure ["m"] + intLib <- getIntegerPackage + gmpLibs <- notStage0 ? intLib == integerGmp ? pure ["gmp"] + mconcat [ (Dynamic `wayUnit` way) ? + pure [ "-shared", "-dynamic", "-dynload", "deploy" ] + , arg "-no-auto-link-packages" + , nonHsMainPackage pkg ? arg "-no-hs-main" + , not (nonHsMainPackage pkg) ? arg "-rtsopts" + , pure [ "-optl-l" ++ lib | lib <- libs ++ gmpLibs ] + ] + +findHsDependencies :: Args +findHsDependencies = builder (Ghc FindHsDependencies) ? do + ways <- getLibraryWays + mconcat [ arg "-M" + , commonGhcArgs + , arg "-include-pkg-deps" + , arg "-dep-makefile", arg =<< getOutput + , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- ways ] + , getInputs ] + +haddockGhcArgs :: Args +haddockGhcArgs = mconcat [ commonGhcArgs, getContextData hcOpts ] + +-- | Common GHC command line arguments used in 'ghcBuilderArgs', +-- 'ghcCBuilderArgs', 'ghcMBuilderArgs' and 'haddockGhcArgs'. +commonGhcArgs :: Args +commonGhcArgs = do + way <- getWay + path <- getBuildPath + ghcVersion <- expr ghcVersionH + mconcat [ arg "-hisuf", arg $ hisuf way + , arg "-osuf" , arg $ osuf way + , arg "-hcsuf", arg $ hcsuf way + , wayGhcArgs + , packageGhcArgs + , includeGhcArgs + -- When compiling RTS for Stage1 or Stage2 we do not have it (yet) + -- in the package database. We therefore explicity supply the path + -- to the @ghc-version@ file, to prevent GHC from trying to open the + -- RTS package in the package database and failing. + , package rts ? notStage0 ? arg ("-ghcversion-file=" ++ ghcVersion) + , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs + , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs + , map ("-optP" ++) <$> getContextData cppOpts + , arg "-odir" , arg path + , arg "-hidir" , arg path + , arg "-stubdir" , arg path ] + +-- TODO: Do '-ticky' in all debug ways? +wayGhcArgs :: Args +wayGhcArgs = do + way <- getWay + mconcat [ if (Dynamic `wayUnit` way) + then pure ["-fPIC", "-dynamic"] + else arg "-static" + , (Threaded `wayUnit` way) ? arg "-optc-DTHREADED_RTS" + , (Debug `wayUnit` way) ? arg "-optc-DDEBUG" + , (Profiling `wayUnit` way) ? arg "-prof" + , (Logging `wayUnit` way) ? arg "-eventlog" + , (way == debug || way == debugDynamic) ? + pure ["-ticky", "-DTICKY_TICKY"] ] + +packageGhcArgs :: Args +packageGhcArgs = do + package <- getPackage + pkgId <- expr $ pkgIdentifier package + mconcat [ arg "-hide-all-packages" + , arg "-no-user-package-db" + , packageDatabaseArgs + , libraryPackage ? arg ("-this-unit-id " ++ pkgId) + , map ("-package-id " ++) <$> getContextData depIds ] + +includeGhcArgs :: Args +includeGhcArgs = do + pkg <- getPackage + path <- getBuildPath + root <- getBuildRoot + context <- getContext + srcDirs <- getContextData srcDirs + autogen <- expr $ autogenPath context + mconcat [ arg "-i" + , arg $ "-i" ++ path + , arg $ "-i" ++ autogen + , pure [ "-i" ++ pkgPath pkg -/- dir | dir <- srcDirs ] + , cIncludeArgs + , arg $ "-I" ++ root -/- generatedDir + , arg $ "-optc-I" ++ root -/- generatedDir + , pure ["-optP-include", "-optP" ++ autogen -/- "cabal_macros.h"] ] diff --git a/hadrian/src/Settings/Builders/GhcPkg.hs b/hadrian/src/Settings/Builders/GhcPkg.hs new file mode 100644 index 0000000000..bc8303f5a1 --- /dev/null +++ b/hadrian/src/Settings/Builders/GhcPkg.hs @@ -0,0 +1,39 @@ +module Settings.Builders.GhcPkg (ghcPkgBuilderArgs) where + +import Settings.Builders.Common + +ghcPkgBuilderArgs :: Args +ghcPkgBuilderArgs = mconcat + [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ] + , builder (GhcPkg Copy) ? do + verbosity <- expr getVerbosity + stage <- getStage + pkgDb <- expr $ packageDbPath stage + mconcat [ arg "--global-package-db" + , arg pkgDb + , arg "register" + , verbosity < Chatty ? arg "-v0" + ] + , builder (GhcPkg Unregister) ? do + verbosity <- expr getVerbosity + stage <- getStage + pkgDb <- expr $ packageDbPath stage + mconcat [ arg "--global-package-db" + , arg pkgDb + , arg "unregister" + , arg "--force" + , verbosity < Chatty ? arg "-v0" + ] + , builder (GhcPkg Update) ? do + verbosity <- expr getVerbosity + context <- getContext + config <- expr $ pkgInplaceConfig context + stage <- getStage + pkgDb <- expr $ packageDbPath stage + mconcat [ notStage0 ? arg "--global-package-db" + , notStage0 ? arg pkgDb + , arg "update" + , arg "--force" + , verbosity < Chatty ? arg "-v0" + , bootPackageDatabaseArgs + , arg config ] ] diff --git a/hadrian/src/Settings/Builders/Haddock.hs b/hadrian/src/Settings/Builders/Haddock.hs new file mode 100644 index 0000000000..2830c209e7 --- /dev/null +++ b/hadrian/src/Settings/Builders/Haddock.hs @@ -0,0 +1,71 @@ +module Settings.Builders.Haddock (haddockBuilderArgs) where + +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type +import Hadrian.Utilities + +import Packages +import Rules.Documentation +import Settings.Builders.Common +import Settings.Builders.Ghc + +-- | Given a version string such as "2.16.2" produce an integer equivalent. +versionToInt :: String -> Int +versionToInt = read . dropWhile (=='0') . filter (/='.') + +haddockBuilderArgs :: Args +haddockBuilderArgs = mconcat + [ builder (Haddock BuildIndex) ? do + output <- getOutput + inputs <- getInputs + root <- getBuildRoot + mconcat + [ arg $ "-B" ++ root -/- "stage1" -/- "lib" + , arg $ "--lib=" ++ root -/- "docs" + , arg "--gen-index" + , arg "--gen-contents" + , arg "-o", arg $ takeDirectory output + , arg "-t", arg "Haskell Hierarchical Libraries" + , arg "-p", arg "libraries/prologue.txt" + , pure [ "--read-interface=" + ++ (takeFileName . takeDirectory) haddock + ++ "," ++ haddock | haddock <- inputs ] ] + + , builder (Haddock BuildPackage) ? do + output <- getOutput + pkg <- getPackage + root <- getBuildRoot + path <- getBuildPath + context <- getContext + version <- expr $ pkgVersion pkg + synopsis <- expr $ pkgSynopsis pkg + deps <- getContextData depNames + haddocks <- expr $ haddockDependencies context + hVersion <- expr $ pkgVersion haddock + ghcOpts <- haddockGhcArgs + mconcat + [ arg "--verbosity=0" + , arg $ "-B" ++ root -/- "stage1" -/- "lib" + , arg $ "--lib=" ++ root -/- "docs" + , arg $ "--odir=" ++ takeDirectory output + , arg "--no-tmp-comp-dir" + , arg $ "--dump-interface=" ++ output + , arg "--html" + , arg "--hyperlinked-source" + , arg "--hoogle" + , arg "--quickjump" + , arg $ "--title=" ++ pkgName pkg ++ "-" ++ version + ++ ": " ++ synopsis + , arg $ "--prologue=" ++ takeDirectory output -/- "haddock-prologue.txt" + , arg $ "--optghc=-D__HADDOCK_VERSION__=" + ++ show (versionToInt hVersion) + , map ("--hide=" ++) <$> getContextData otherModules + , pure [ "--read-interface=../" ++ dep + ++ ",../" ++ dep ++ "/src/%{MODULE}.html#%{NAME}," + ++ haddock | (dep, haddock) <- zip deps haddocks ] + , pure [ "--optghc=" ++ opt | opt <- ghcOpts, not ("--package-db" `isInfixOf` opt) ] + , getInputs + , arg "+RTS" + , arg $ "-t" ++ path -/- "haddock.t" + , arg "--machine-readable" + , arg "-RTS" ] ] diff --git a/hadrian/src/Settings/Builders/Happy.hs b/hadrian/src/Settings/Builders/Happy.hs new file mode 100644 index 0000000000..5ffb2614cc --- /dev/null +++ b/hadrian/src/Settings/Builders/Happy.hs @@ -0,0 +1,9 @@ +module Settings.Builders.Happy (happyBuilderArgs) where + +import Settings.Builders.Common + +happyBuilderArgs :: Args +happyBuilderArgs = builder Happy ? mconcat [ arg "-agc" + , arg "--strict" + , arg =<< getInput + , arg "-o", arg =<< getOutput ] diff --git a/hadrian/src/Settings/Builders/HsCpp.hs b/hadrian/src/Settings/Builders/HsCpp.hs new file mode 100644 index 0000000000..e33061c9d0 --- /dev/null +++ b/hadrian/src/Settings/Builders/HsCpp.hs @@ -0,0 +1,17 @@ +module Settings.Builders.HsCpp (hsCppBuilderArgs) where + +import Packages +import Settings.Builders.Common + +hsCppBuilderArgs :: Args +hsCppBuilderArgs = builder HsCpp ? do + stage <- getStage + root <- getBuildRoot + ghcPath <- expr $ buildPath (vanillaContext stage compiler) + mconcat [ getSettingList HsCppArgs + , arg "-P" + , arg "-Iincludes" + , arg $ "-I" ++ root -/- generatedDir + , arg $ "-I" ++ ghcPath + , arg "-x", arg "c" + , arg =<< getInput ] diff --git a/hadrian/src/Settings/Builders/Hsc2Hs.hs b/hadrian/src/Settings/Builders/Hsc2Hs.hs new file mode 100644 index 0000000000..0d5363d413 --- /dev/null +++ b/hadrian/src/Settings/Builders/Hsc2Hs.hs @@ -0,0 +1,58 @@ +module Settings.Builders.Hsc2Hs (hsc2hsBuilderArgs) where + +import Hadrian.Haskell.Cabal.Type + +import Builder +import Packages +import Settings.Builders.Common + +hsc2hsBuilderArgs :: Args +hsc2hsBuilderArgs = builder Hsc2Hs ? do + stage <- getStage + ccPath <- getBuilderPath $ Cc CompileC stage + gmpDir <- getSetting GmpIncludeDir + top <- expr topDirectory + hArch <- getSetting HostArch + hOs <- getSetting HostOs + tArch <- getSetting TargetArch + tOs <- getSetting TargetOs + version <- if stage == Stage0 + then expr ghcCanonVersion + else getSetting ProjectVersionInt + tmpl <- (top -/-) <$> expr (templateHscPath Stage0) + mconcat [ arg $ "--cc=" ++ ccPath + , arg $ "--ld=" ++ ccPath + , notM windowsHost ? notM (flag CrossCompiling) ? arg "--cross-safe" + , pure $ map ("-I" ++) (words gmpDir) + , map ("--cflag=" ++) <$> getCFlags + , map ("--lflag=" ++) <$> getLFlags + , notStage0 ? flag CrossCompiling ? arg "--cross-compile" + , stage0 ? arg ("--cflag=-D" ++ hArch ++ "_HOST_ARCH=1") + , stage0 ? arg ("--cflag=-D" ++ hOs ++ "_HOST_OS=1" ) + , notStage0 ? arg ("--cflag=-D" ++ tArch ++ "_HOST_ARCH=1") + , notStage0 ? arg ("--cflag=-D" ++ tOs ++ "_HOST_OS=1" ) + , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version + , arg $ "--template=" ++ tmpl + , arg =<< getInput + , arg "-o", arg =<< getOutput ] + +getCFlags :: Expr [String] +getCFlags = do + context <- getContext + autogen <- expr $ autogenPath context + mconcat [ remove ["-O"] (cArgs <> getStagedSettingList ConfCcArgs) + , getStagedSettingList ConfCppArgs + , cIncludeArgs + , getContextData ccOpts + -- we might be able to leave out cppOpts, to be investigated. + , getContextData cppOpts + , getContextData depCcOpts + , cWarnings + , arg "-include", arg $ autogen -/- "cabal_macros.h" ] + +getLFlags :: Expr [String] +getLFlags = + mconcat [ getStagedSettingList ConfGccLinkerArgs + , ldArgs + , getContextData ldOpts + , getContextData depLdOpts ] diff --git a/hadrian/src/Settings/Builders/Ld.hs b/hadrian/src/Settings/Builders/Ld.hs new file mode 100644 index 0000000000..2715bbb20c --- /dev/null +++ b/hadrian/src/Settings/Builders/Ld.hs @@ -0,0 +1,9 @@ +module Settings.Builders.Ld (ldBuilderArgs) where + +import Settings.Builders.Common + +ldBuilderArgs :: Args +ldBuilderArgs = builder Ld ? mconcat [ getStagedSettingList ConfLdLinkerArgs + , arg "-r" + , arg "-o", arg =<< getOutput + , getInputs ] diff --git a/hadrian/src/Settings/Builders/Make.hs b/hadrian/src/Settings/Builders/Make.hs new file mode 100644 index 0000000000..102ba54845 --- /dev/null +++ b/hadrian/src/Settings/Builders/Make.hs @@ -0,0 +1,41 @@ +module Settings.Builders.Make (makeBuilderArgs, validateBuilderArgs) where + +import Oracles.Setting +import Packages +import Rules.Gmp +import Settings.Builders.Common +import CommandLine + +makeBuilderArgs :: Args +makeBuilderArgs = do + threads <- shakeThreads <$> expr getShakeOptions + gmpPath <- expr gmpBuildPath + libffiPath <- expr libffiBuildPath + let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads + mconcat + [ builder (Make gmpPath ) ? pure ["MAKEFLAGS=-j" ++ t] + , builder (Make libffiPath) ? pure ["MAKEFLAGS=-j" ++ t, "install"] ] + +validateBuilderArgs :: Args +validateBuilderArgs = builder (Make "testsuite/tests") ? do + threads <- shakeThreads <$> expr getShakeOptions + top <- expr topDirectory + compiler <- expr $ fullpath ghc + checkPpr <- expr $ fullpath checkPpr + checkApiAnnotations <- expr $ fullpath checkApiAnnotations + args <- expr $ userSetting defaultTestArgs + return [ setTestSpeed $ testSpeed args + , "THREADS=" ++ show threads + , "TEST_HC=" ++ (top -/- compiler) + , "CHECK_PPR=" ++ (top -/- checkPpr) + , "CHECK_API_ANNOTATIONS=" ++ (top -/- checkApiAnnotations) + ] + where + fullpath :: Package -> Action FilePath + fullpath pkg = programPath =<< programContext Stage1 pkg + +-- | Support for speed of validation +setTestSpeed :: TestSpeed -> String +setTestSpeed Fast = "fasttest" +setTestSpeed Average = "test" +setTestSpeed Slow = "slowtest" diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs new file mode 100644 index 0000000000..734fecdb49 --- /dev/null +++ b/hadrian/src/Settings/Builders/RunTest.hs @@ -0,0 +1,205 @@ +module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where + +import Hadrian.Utilities +import System.Environment + +import CommandLine +import Flavour +import Oracles.Setting (setting) +import Oracles.TestSettings +import Packages +import Settings.Builders.Common + +getTestSetting :: TestSetting -> Expr String +getTestSetting key = expr $ testSetting key + +-- | Parse the value of a Boolean test setting or report an error. +getBooleanSetting :: TestSetting -> Expr Bool +getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key + where + msg = "Cannot parse test setting " ++ quote (show key) + +-- | Extra flags to send to the Haskell compiler to run tests. +runTestGhcFlags :: Action String +runTestGhcFlags = do + unregisterised <- flag GhcUnregisterised + + let ifMinGhcVer ver opt = do v <- ghcCanonVersion + if ver <= v then pure opt + else pure "" + + -- Read extra argument for test from command line, like `-fvectorize`. + ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS") + + -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28 + let ghcExtraFlags = if unregisterised + then "-optc-fno-builtin" + else "" + + -- Take flags to send to the Haskell compiler from test.mk. + -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37 + unwords <$> sequence + [ pure " -dcore-lint -dcmm-lint -no-user-package-db -rtsopts" + , pure ghcOpts + , pure ghcExtraFlags + , ifMinGhcVer "711" "-fno-warn-missed-specialisations" + , ifMinGhcVer "711" "-fshow-warning-groups" + , ifMinGhcVer "801" "-fdiagnostics-color=never" + , ifMinGhcVer "801" "-fno-diagnostics-show-caret" + , pure "-dno-debug-output" + ] + +-- Command line arguments for invoking the @runtest.py@ script. A lot of this +-- mirrors @testsuite/mk/test.mk@. +runTestBuilderArgs :: Args +runTestBuilderArgs = builder RunTest ? do + pkgs <- expr $ stagePackages Stage1 + libTests <- expr $ filterM doesDirectoryExist $ concat + [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ] + | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ] + + flav <- expr flavour + rtsWays <- expr testRTSSettings + libWays <- libraryWays flav + let hasRtsWay w = elem w rtsWays + hasLibWay w = elem w libWays + debugged = ghcDebugged flav + hasDynamic <- getBooleanSetting TestGhcDynamic + hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault + withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen + withInterpreter <- getBooleanSetting TestGhcWithInterpreter + unregisterised <- getBooleanSetting TestGhcUnregisterised + withSMP <- getBooleanSetting TestGhcWithSMP + + windows <- expr windowsHost + darwin <- expr osxHost + threads <- shakeThreads <$> expr getShakeOptions + os <- getTestSetting TestHostOS + arch <- getTestSetting TestTargetARCH_CPP + platform <- getTestSetting TestTARGETPLATFORM + wordsize <- getTestSetting TestWORDSIZE + top <- expr $ topDirectory + ghcFlags <- expr runTestGhcFlags + timeoutProg <- expr buildRoot <&> (-/- timeoutPath) + + let asZeroOne s b = s ++ zeroOne b + + -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD + mconcat [ arg $ "testsuite/driver/runtests.py" + , arg $ "--rootdir=" ++ ("testsuite" -/- "tests") + , pure ["--rootdir=" ++ test | test <- libTests] + , arg "-e", arg $ "windows=" ++ show windows + , arg "-e", arg $ "darwin=" ++ show darwin + , arg "-e", arg $ "config.local=True" + , arg "-e", arg $ "config.cleanup=False" -- Don't clean up. + , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged) + , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged) + , arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen + + , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter + , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised + + , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags + , arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts=" (hasRtsWay "dyn") + , arg "-e", arg $ asZeroOne "ghc_with_threaded_rts=" (hasRtsWay "thr") + , arg "-e", arg $ asZeroOne "config.have_vanilla=" (hasLibWay vanilla) + , arg "-e", arg $ asZeroOne "config.have_dynamic=" (hasLibWay dynamic) + , arg "-e", arg $ asZeroOne "config.have_profiling=" (hasLibWay profiling) + , arg "-e", arg $ asZeroOne "ghc_with_smp=" withSMP + , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM + + , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault + , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic + + -- Use default value, see: + -- https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk + , arg "-e", arg $ "config.in_tree_compiler=True" + , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite") + , arg "-e", arg $ "config.wordsize=" ++ show wordsize + , arg "-e", arg $ "config.os=" ++ show os + , arg "-e", arg $ "config.arch=" ++ show arch + , arg "-e", arg $ "config.platform=" ++ show platform + + , arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk + , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg) + , arg $ "--threads=" ++ show threads + , getTestArgs -- User-provided arguments from command line. + ] + +-- | Command line arguments for running GHC's test script. +getTestArgs :: Args +getTestArgs = do + args <- expr $ userSetting defaultTestArgs + bindir <- expr $ setBinaryDirectory (testCompiler args) + compiler <- expr $ setCompiler (testCompiler args) + globalVerbosity <- shakeVerbosity <$> expr getShakeOptions + let configFileArg= ["--config-file=" ++ (testConfigFile args)] + testOnlyArg = case testOnly args of + Just cases -> map ("--only=" ++) (words cases) + Nothing -> [] + onlyPerfArg = if testOnlyPerf args + then Just "--only-perf-tests" + else Nothing + skipPerfArg = if testSkipPerf args + then Just "--skip-perf-tests" + else Nothing + speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)] + summaryArg = case testSummary args of + Just filepath -> Just $ "--summary-file" ++ quote filepath + Nothing -> Just $ "--summary-file=testsuite_summary.txt" + junitArg = case testJUnit args of + Just filepath -> Just $ "--junit " ++ quote filepath + Nothing -> Nothing + configArgs = concat [["-e", configArg] | configArg <- testConfigs args] + verbosityArg = case testVerbosity args of + Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity) + Just verbosity -> Just $ "--verbose=" ++ verbosity + wayArgs = map ("--way=" ++) (testWays args) + compilerArg = ["--config", "compiler=" ++ show (compiler)] + ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")] + haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")] + hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")] + hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")] + pure $ configFileArg ++ testOnlyArg ++ speedArg + ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg + , junitArg, verbosityArg ] + ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg + ++ haddockArg ++ hp2psArg ++ hpcArg + +-- TODO: Switch to 'Stage' as the first argument instead of 'String'. +-- | Directory to look for Binaries +-- | We assume that required programs are present in the same binary directory +-- | in which ghc is stored and that they have their conventional name. +-- | QUESTION : packages can be named different from their conventional names. +-- | For example, ghc-pkg can be named as ghc-pkg-version. In such cases, it will +-- | be impossible to search the binary. Only possible way will be to take user +-- | inputs for these directory also. boilerplate soes not account for this +-- | problem, but simply returns an error. How should we handle such cases? +setBinaryDirectory :: String -> Action FilePath +setBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc +setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0) +setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1) +setBinaryDirectory compiler = pure $ parentPath compiler + +-- TODO: Switch to 'Stage' as the first argument instead of 'String'. +-- | Set Test Compiler. +setCompiler :: String -> Action FilePath +setCompiler "stage0" = setting SystemGhc +setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc) +setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc) +setCompiler compiler = pure compiler + +-- | Set speed for test +setTestSpeed :: TestSpeed -> String +setTestSpeed Slow = "0" +setTestSpeed Average = "1" +setTestSpeed Fast = "2" + +-- | Returns parent path of test compiler +-- | TODO: Is there a simpler way to find parent directory? +parentPath :: String -> String +parentPath path = intercalate "/" $ init $ splitOn "/" path + +-- | TODO: Move to Hadrian utilities. +fullPath :: Stage -> Package -> Action FilePath +fullPath stage pkg = programPath =<< programContext stage pkg diff --git a/hadrian/src/Settings/Builders/Xelatex.hs b/hadrian/src/Settings/Builders/Xelatex.hs new file mode 100644 index 0000000000..5623284ed5 --- /dev/null +++ b/hadrian/src/Settings/Builders/Xelatex.hs @@ -0,0 +1,7 @@ +module Settings.Builders.Xelatex (xelatexBuilderArgs) where + +import Settings.Builders.Common + +xelatexBuilderArgs :: Args +xelatexBuilderArgs = builder Xelatex ? mconcat [ arg "-halt-on-error" + , arg =<< getInput ] diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs new file mode 100644 index 0000000000..031bd45ace --- /dev/null +++ b/hadrian/src/Settings/Default.hs @@ -0,0 +1,274 @@ +module Settings.Default ( + -- * Packages that are build by default and for the testsuite + defaultPackages, testsuitePackages, + + -- * Default build ways + defaultLibraryWays, defaultRtsWays, + + -- * Default command line arguments for various builders + SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs, + defaultArgs, + + -- * Default build flavour + defaultFlavour, defaultSplitObjects + ) where + +import qualified Hadrian.Builder.Ar +import qualified Hadrian.Builder.Sphinx +import qualified Hadrian.Builder.Tar +import Hadrian.Haskell.Cabal.Type + +import CommandLine +import Expression +import Flavour +import Oracles.Flag +import Oracles.Setting +import Packages +import Settings +import Settings.Builders.Alex +import Settings.Builders.DeriveConstants +import Settings.Builders.Cabal +import Settings.Builders.Cc +import Settings.Builders.Configure +import Settings.Builders.GenPrimopCode +import Settings.Builders.Ghc +import Settings.Builders.GhcPkg +import Settings.Builders.Haddock +import Settings.Builders.Happy +import Settings.Builders.Hsc2Hs +import Settings.Builders.HsCpp +import Settings.Builders.Ld +import Settings.Builders.Make +import Settings.Builders.RunTest +import Settings.Builders.Xelatex +import Settings.Packages +import Settings.Warnings + +-- | Packages that are built by default. You can change this in "UserSettings". +defaultPackages :: Stage -> Action [Package] +defaultPackages Stage0 = stage0Packages +defaultPackages Stage1 = stage1Packages +defaultPackages Stage2 = stage2Packages +defaultPackages Stage3 = return [] + +-- | Packages built in 'Stage0' by default. You can change this in "UserSettings". +stage0Packages :: Action [Package] +stage0Packages = do + win <- windowsHost + cross <- flag CrossCompiling + return $ [ binary + , cabal + , compareSizes + , compiler + , deriveConstants + , genapply + , genprimopcode + , ghc + , ghcBoot + , ghcBootTh + , ghcHeap + , ghci + , ghcPkg + , hsc2hs + , hpc + , mtl + , parsec + , templateHaskell + , text + , transformers + , unlit ] + ++ [ terminfo | not win, not cross ] + ++ [ touchy | win ] + +-- | Packages built in 'Stage1' by default. You can change this in "UserSettings". +stage1Packages :: Action [Package] +stage1Packages = do + win <- windowsHost + intLib <- integerLibrary =<< flavour + libraries0 <- filter isLibrary <$> stage0Packages + cross <- flag CrossCompiling + return $ libraries0 -- Build all Stage0 libraries in Stage1 + ++ [ array + , base + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc + , ghcCompact + , ghcPkg + , ghcPrim + , haskeline + , hsc2hs + , intLib + , pretty + , process + , rts + , stm + , time + , unlit + , xhtml ] + ++ [ hpcBin | not cross ] + ++ [ iserv | not win, not cross ] + ++ [ libiserv | not win, not cross ] + ++ [ runGhc | not cross ] + ++ [ touchy | win ] + ++ [ unix | not win ] + ++ [ win32 | win ] + +-- | Packages built in 'Stage2' by default. You can change this in "UserSettings". +stage2Packages :: Action [Package] +stage2Packages = do + cross <- flag CrossCompiling + return $ [ ghcTags ] + ++ [ haddock | not cross ] + +-- | Packages that are built only for the testsuite. +testsuitePackages :: Action [Package] +testsuitePackages = do + win <- windowsHost + return $ [ checkApiAnnotations + , checkPpr + , ghci + , ghcCompact + , ghcPkg + , hp2ps + , hsc2hs + , iserv + , parallel + , runGhc + , unlit ] ++ + [ timeout | win ] + +-- | Default build ways for library packages: +-- * We always build 'vanilla' way. +-- * We build 'profiling' way when stage > Stage0. +-- * We build 'dynamic' way when stage > Stage0 and the platform supports it. +defaultLibraryWays :: Ways +defaultLibraryWays = mconcat + [ pure [vanilla] + , notStage0 ? pure [profiling] + , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] + ] + +-- | Default build ways for the RTS. +defaultRtsWays :: Ways +defaultRtsWays = mconcat + [ pure [vanilla, threaded] + , notStage0 ? pure + [ profiling, threadedProfiling, debugProfiling, threadedDebugProfiling + , logging, threadedLogging + , debug, threadedDebug + ] + , notStage0 ? platformSupportsSharedLibs ? pure + [ dynamic, threadedDynamic, debugDynamic, loggingDynamic + , threadedDebugDynamic, threadedLoggingDynamic + ] + ] + +-- TODO: Move C source arguments here +-- | Default and package-specific source arguments. +data SourceArgs = SourceArgs + { hsDefault :: Args + , hsLibrary :: Args + , hsCompiler :: Args + , hsGhc :: Args } + +-- | Concatenate source arguments in appropriate order. +sourceArgs :: SourceArgs -> Args +sourceArgs SourceArgs {..} = builder Ghc ? mconcat + [ hsDefault + , getContextData hcOpts + , libraryPackage ? hsLibrary + , package compiler ? hsCompiler + , package ghc ? hsGhc ] + +-- | All default command line arguments. +defaultArgs :: Args +defaultArgs = mconcat + [ defaultBuilderArgs + , sourceArgs defaultSourceArgs + , defaultPackageArgs ] + +-- | Default source arguments, e.g. optimisation settings. +defaultSourceArgs :: SourceArgs +defaultSourceArgs = SourceArgs + { hsDefault = mconcat [ stage0 ? arg "-O" + , notStage0 ? arg "-O2" + , arg "-H32m" ] + , hsLibrary = mempty + , hsCompiler = mempty + , hsGhc = mempty } + +-- Please update doc/flavours.md when changing the default build flavour. +-- | Default build flavour. Other build flavours are defined in modules +-- @Settings.Flavours.*@. Users can add new build flavours in "UserSettings". +defaultFlavour :: Flavour +defaultFlavour = Flavour + { name = "default" + , args = defaultArgs + , packages = defaultPackages + , integerLibrary = (\x -> if x then integerSimple else integerGmp) <$> cmdIntegerSimple + , libraryWays = defaultLibraryWays + , rtsWays = defaultRtsWays + , splitObjects = defaultSplitObjects + , dynamicGhcPrograms = defaultDynamicGhcPrograms + , ghciWithDebugger = False + , ghcProfiled = False + , ghcDebugged = False } + +-- | Default logic for determining whether to build +-- dynamic GHC programs. +-- +-- It corresponds to the DYNAMIC_GHC_PROGRAMS logic implemented +-- in @mk/config.mk.in@. +defaultDynamicGhcPrograms :: Action Bool +defaultDynamicGhcPrograms = do + win <- windowsHost + supportsShared <- platformSupportsSharedLibs + return (not win && supportsShared) + +-- | Default condition for building split objects. +defaultSplitObjects :: Predicate +defaultSplitObjects = do + goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages + pkg <- getPackage + supported <- expr supportsSplitObjects + split <- expr cmdSplitObjects + let goodPackage = isLibrary pkg && pkg /= compiler && pkg /= rts + return $ split && goodStage && goodPackage && supported + +-- | All 'Builder'-dependent command line arguments. +defaultBuilderArgs :: Args +defaultBuilderArgs = mconcat + -- GHC-specific builders: + [ alexBuilderArgs + , cabalBuilderArgs + , ccBuilderArgs + , configureBuilderArgs + , deriveConstantsBuilderArgs + , genPrimopCodeBuilderArgs + , ghcBuilderArgs + , ghcPkgBuilderArgs + , haddockBuilderArgs + , happyBuilderArgs + , hsc2hsBuilderArgs + , hsCppBuilderArgs + , ldBuilderArgs + , makeBuilderArgs + , runTestBuilderArgs + , validateBuilderArgs + , xelatexBuilderArgs + -- Generic builders from the Hadrian library: + , builder (Ar Pack ) ? Hadrian.Builder.Ar.args Pack + , builder (Ar Unpack ) ? Hadrian.Builder.Ar.args Unpack + , builder (Sphinx Html ) ? Hadrian.Builder.Sphinx.args Html + , builder (Sphinx Latex) ? Hadrian.Builder.Sphinx.args Latex + , builder (Sphinx Man ) ? Hadrian.Builder.Sphinx.args Man + , builder (Tar Create ) ? Hadrian.Builder.Tar.args Create + , builder (Tar Extract ) ? Hadrian.Builder.Tar.args Extract ] + +-- | All 'Package'-dependent command line arguments. +defaultPackageArgs :: Args +defaultPackageArgs = mconcat [ packageArgs, warningArgs ] diff --git a/hadrian/src/Settings/Default.hs-boot b/hadrian/src/Settings/Default.hs-boot new file mode 100644 index 0000000000..30a28497e9 --- /dev/null +++ b/hadrian/src/Settings/Default.hs-boot @@ -0,0 +1,21 @@ +module Settings.Default ( + SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs, + defaultArgs, defaultLibraryWays, defaultRtsWays, + defaultFlavour, defaultSplitObjects + ) where + +import Flavour +import Expression + +data SourceArgs = SourceArgs + { hsDefault :: Args + , hsLibrary :: Args + , hsCompiler :: Args + , hsGhc :: Args } + +sourceArgs :: SourceArgs -> Args + +defaultBuilderArgs, defaultPackageArgs, defaultArgs :: Args +defaultLibraryWays, defaultRtsWays :: Ways +defaultFlavour :: Flavour +defaultSplitObjects :: Predicate diff --git a/hadrian/src/Settings/Flavours/Common.hs b/hadrian/src/Settings/Flavours/Common.hs new file mode 100644 index 0000000000..a1eb2fbba9 --- /dev/null +++ b/hadrian/src/Settings/Flavours/Common.hs @@ -0,0 +1,11 @@ +module Settings.Flavours.Common where + +import Expression + +-- See https://ghc.haskell.org/trac/ghc/ticket/15286 and +-- https://phabricator.haskell.org/D4880 +naturalInBaseFixArgs :: Args +naturalInBaseFixArgs = mconcat + [ input "//Natural.hs" ? pure ["-fno-omit-interface-pragmas"] + , input "//Num.hs" ? pure ["-fno-ignore-interface-pragmas"] + ] diff --git a/hadrian/src/Settings/Flavours/Development.hs b/hadrian/src/Settings/Flavours/Development.hs new file mode 100644 index 0000000000..5919026cb0 --- /dev/null +++ b/hadrian/src/Settings/Flavours/Development.hs @@ -0,0 +1,20 @@ +module Settings.Flavours.Development (developmentFlavour) where + +import Expression +import Flavour +import {-# SOURCE #-} Settings.Default + +-- Please update doc/flavours.md when changing this file. +developmentFlavour :: Stage -> Flavour +developmentFlavour ghcStage = defaultFlavour + { name = "devel" ++ show (fromEnum ghcStage) + , args = defaultBuilderArgs <> developmentArgs ghcStage <> defaultPackageArgs } + +developmentArgs :: Stage -> Args +developmentArgs ghcStage = do + stage <- getStage + sourceArgs SourceArgs + { hsDefault = pure ["-O", "-H64m"] + , hsLibrary = notStage0 ? arg "-dcore-lint" + , hsCompiler = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"] + , hsGhc = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"] } diff --git a/hadrian/src/Settings/Flavours/Performance.hs b/hadrian/src/Settings/Flavours/Performance.hs new file mode 100644 index 0000000000..64ab4bce9d --- /dev/null +++ b/hadrian/src/Settings/Flavours/Performance.hs @@ -0,0 +1,18 @@ +module Settings.Flavours.Performance (performanceFlavour) where + +import Expression +import Flavour +import {-# SOURCE #-} Settings.Default + +-- Please update doc/flavours.md when changing this file. +performanceFlavour :: Flavour +performanceFlavour = defaultFlavour + { name = "perf" + , args = defaultBuilderArgs <> performanceArgs <> defaultPackageArgs } + +performanceArgs :: Args +performanceArgs = sourceArgs SourceArgs + { hsDefault = pure ["-O", "-H64m"] + , hsLibrary = notStage0 ? arg "-O2" + , hsCompiler = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"] + , hsGhc = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"] } diff --git a/hadrian/src/Settings/Flavours/Profiled.hs b/hadrian/src/Settings/Flavours/Profiled.hs new file mode 100644 index 0000000000..91b7f3b188 --- /dev/null +++ b/hadrian/src/Settings/Flavours/Profiled.hs @@ -0,0 +1,23 @@ +module Settings.Flavours.Profiled (profiledFlavour) where + +import Expression +import Flavour +import {-# SOURCE #-} Settings.Default +import Settings.Flavours.Common (naturalInBaseFixArgs) + +-- Please update doc/flavours.md when changing this file. +profiledFlavour :: Flavour +profiledFlavour = defaultFlavour + { name = "prof" + , args = defaultBuilderArgs <> profiledArgs <> defaultPackageArgs + , ghcProfiled = True } + +profiledArgs :: Args +profiledArgs = sourceArgs SourceArgs + { hsDefault = mconcat + [ pure ["-O0", "-H64m"] + , naturalInBaseFixArgs + ] + , hsLibrary = notStage0 ? arg "-O" + , hsCompiler = arg "-O" + , hsGhc = arg "-O" } diff --git a/hadrian/src/Settings/Flavours/Quick.hs b/hadrian/src/Settings/Flavours/Quick.hs new file mode 100644 index 0000000000..59b58eb413 --- /dev/null +++ b/hadrian/src/Settings/Flavours/Quick.hs @@ -0,0 +1,34 @@ +module Settings.Flavours.Quick (quickFlavour) where + +import Expression +import Flavour +import Oracles.Flag +import {-# SOURCE #-} Settings.Default +import Settings.Flavours.Common + +-- Please update doc/flavours.md when changing this file. +quickFlavour :: Flavour +quickFlavour = defaultFlavour + { name = "quick" + , args = defaultBuilderArgs <> quickArgs <> defaultPackageArgs + , libraryWays = mconcat + [ pure [vanilla] + , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] + , rtsWays = mconcat + [ pure + [ vanilla, threaded, logging, debug + , threadedDebug, threadedLogging, threaded ] + , notStage0 ? platformSupportsSharedLibs ? pure + [ dynamic, debugDynamic, threadedDynamic, loggingDynamic + , threadedDebugDynamic, threadedLoggingDynamic ] + ] } + +quickArgs :: Args +quickArgs = sourceArgs SourceArgs + { hsDefault = mconcat $ + [ pure ["-O0", "-H64m"] + , naturalInBaseFixArgs + ] + , hsLibrary = notStage0 ? arg "-O" + , hsCompiler = stage0 ? arg "-O" + , hsGhc = stage0 ? arg "-O" } diff --git a/hadrian/src/Settings/Flavours/QuickCross.hs b/hadrian/src/Settings/Flavours/QuickCross.hs new file mode 100644 index 0000000000..7572be27d1 --- /dev/null +++ b/hadrian/src/Settings/Flavours/QuickCross.hs @@ -0,0 +1,37 @@ +module Settings.Flavours.QuickCross (quickCrossFlavour) where + +import Expression +import Flavour +import Oracles.Flag +import {-# SOURCE #-} Settings.Default +import Settings.Flavours.Common + +-- Please update doc/flavours.md when changing this file. +quickCrossFlavour :: Flavour +quickCrossFlavour = defaultFlavour + { name = "quick-cross" + , args = defaultBuilderArgs <> quickCrossArgs <> defaultPackageArgs + , dynamicGhcPrograms = pure False + , libraryWays = mconcat + [ pure [vanilla] + , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] + , rtsWays = mconcat + [ pure + [ vanilla, threaded, logging, debug + , threadedDebug, threadedLogging, threaded ] + , notStage0 ? platformSupportsSharedLibs ? pure + [ dynamic, debugDynamic, threadedDynamic, loggingDynamic + , threadedDebugDynamic, threadedLoggingDynamic ] + ] } + +quickCrossArgs :: Args +quickCrossArgs = sourceArgs SourceArgs + { hsDefault = mconcat $ + [ pure ["-O0", "-H64m"] + , naturalInBaseFixArgs + ] + , hsLibrary = notStage0 ? mconcat [ arg "-O", arg "-fllvm" ] + , hsCompiler = stage0 ? arg "-O" + , hsGhc = mconcat + [ stage0 ? arg "-O" + , stage1 ? mconcat [ arg "-O0", arg "-fllvm" ] ] } diff --git a/hadrian/src/Settings/Flavours/Quickest.hs b/hadrian/src/Settings/Flavours/Quickest.hs new file mode 100644 index 0000000000..3c5f944e7e --- /dev/null +++ b/hadrian/src/Settings/Flavours/Quickest.hs @@ -0,0 +1,24 @@ +module Settings.Flavours.Quickest (quickestFlavour) where + +import Expression +import Flavour +import {-# SOURCE #-} Settings.Default +import Settings.Flavours.Common + +-- Please update doc/flavours.md when changing this file. +quickestFlavour :: Flavour +quickestFlavour = defaultFlavour + { name = "quickest" + , args = defaultBuilderArgs <> quickestArgs <> defaultPackageArgs + , libraryWays = pure [vanilla] + , rtsWays = pure [vanilla, threaded] } + +quickestArgs :: Args +quickestArgs = sourceArgs SourceArgs + { hsDefault = mconcat $ + [ pure ["-O0", "-H64m"] + , naturalInBaseFixArgs + ] + , hsLibrary = mempty + , hsCompiler = stage0 ? arg "-O" + , hsGhc = stage0 ? arg "-O" } diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs new file mode 100644 index 0000000000..4d75e325d4 --- /dev/null +++ b/hadrian/src/Settings/Packages.hs @@ -0,0 +1,361 @@ +module Settings.Packages (packageArgs) where + +import Expression +import Flavour +import Oracles.Setting +import Oracles.Flag +import Packages +import Rules.Gmp +import Settings + +-- | Package-specific command-line arguments. +packageArgs :: Args +packageArgs = do + stage <- getStage + rtsWays <- getRtsWays + path <- getBuildPath + intLib <- getIntegerPackage + compilerPath <- expr $ buildPath (vanillaContext stage compiler) + gmpBuildPath <- expr gmpBuildPath + let includeGmp = "-I" ++ gmpBuildPath -/- "include" + + mconcat + --------------------------------- base --------------------------------- + [ package base ? mconcat + [ builder (Cabal Flags) ? notStage0 ? arg (pkgName intLib) + + -- This fixes the 'unknown symbol stat' issue. + -- See: https://github.com/snowleopard/hadrian/issues/259. + , builder (Ghc CompileCWithGhc) ? arg "-optc-O2" ] + + ------------------------------ bytestring ------------------------------ + , package bytestring ? + builder (Cabal Flags) ? intLib == integerSimple ? arg "integer-simple" + + --------------------------------- cabal -------------------------------- + -- Cabal is a large library and slow to compile. Moreover, we build it + -- for Stage0 only so we can link ghc-pkg against it, so there is little + -- reason to spend the effort to optimise it. + , package cabal ? + stage0 ? builder Ghc ? arg "-O0" + + ------------------------------- compiler ------------------------------- + , package compiler ? mconcat + [ builder Alex ? arg "--latin1" + + , builder (Ghc CompileHs) ? mconcat + [ inputs ["//GHC.hs", "//GhcMake.hs"] ? arg "-fprof-auto" + , input "//Parser.hs" ? + pure ["-fno-ignore-interface-pragmas", "-fcmm-sink" ] ] + + , builder (Cabal Setup) ? mconcat + [ arg $ "--ghc-option=-DSTAGE=" ++ show (fromEnum stage + 1) + , arg "--disable-library-for-ghci" + , anyTargetOs ["openbsd"] ? arg "--ld-options=-E" + , flag GhcUnregisterised ? arg "--ghc-option=-DNO_REGS" + , notM ghcWithSMP ? arg "--ghc-option=-DNOSMP" + , notM ghcWithSMP ? arg "--ghc-option=-optc-DNOSMP" + , (any (wayUnit Threaded) rtsWays) ? + notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS" + , ghcWithInterpreter ? + ghcEnableTablesNextToCode ? + notM (flag GhcUnregisterised) ? + notStage0 ? arg "--ghc-option=-DGHCI_TABLES_NEXT_TO_CODE" + , ghcWithInterpreter ? + ghciWithDebugger <$> flavour ? + notStage0 ? arg "--ghc-option=-DDEBUGGER" + , ghcProfiled <$> flavour ? + notStage0 ? arg "--ghc-pkg-option=--force" ] + + , builder (Cabal Flags) ? mconcat + [ ghcWithNativeCodeGen ? arg "ncg" + , ghcWithInterpreter ? notStage0 ? arg "ghci" + , flag CrossCompiling ? arg "-terminfo" + , notStage0 ? intLib == integerGmp ? + arg "integer-gmp" ] + + , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + + ---------------------------------- ghc --------------------------------- + , package ghc ? mconcat + [ builder Ghc ? arg ("-I" ++ compilerPath) + + , builder (Cabal Flags) ? mconcat + [ ghcWithInterpreter ? notStage0 ? arg "ghci" + , flag CrossCompiling ? arg "-terminfo" + -- the 'threaded' flag is True by default, but + -- let's record explicitly that we link all ghc + -- executables with the threaded runtime. + , arg "threaded" ] ] + + -------------------------------- ghcPkg -------------------------------- + , package ghcPkg ? + builder (Cabal Flags) ? flag CrossCompiling ? arg "-terminfo" + + -------------------------------- ghcPrim ------------------------------- + , package ghcPrim ? mconcat + [ builder (Cabal Flags) ? arg "include-ghc-prim" + + , builder (Cc CompileC) ? (not <$> flag GccIsClang) ? + input "//cbits/atomic.c" ? arg "-Wno-sync-nand" ] + + --------------------------------- ghci --------------------------------- + -- TODO: This should not be @not <$> flag CrossCompiling@. Instead we + -- should ensure that the bootstrap compiler has the same version as the + -- one we are building. + + -- TODO: In that case we also do not need to build most of the Stage1 + -- libraries, as we already know that the compiler comes with the most + -- recent versions. + + -- TODO: The use case here is that we want to build @ghc-proxy@ for the + -- cross compiler. That one needs to be compiled by the bootstrap + -- compiler as it needs to run on the host. Hence @libiserv@ needs + -- @GHCi.TH@, @GHCi.Message@ and @GHCi.Run@ from @ghci@. And those are + -- behind the @-fghci@ flag. + , package ghci ? mconcat + [ notStage0 ? builder (Cabal Flags) ? arg "ghci" + , flag CrossCompiling ? stage0 ? builder (Cabal Flags) ? arg "ghci" ] + + -------------------------------- haddock ------------------------------- + , package haddock ? + builder (Cabal Flags) ? arg "in-ghc-tree" + + ------------------------------- haskeline ------------------------------ + , package haskeline ? + builder (Cabal Flags) ? flag CrossCompiling ? arg "-terminfo" + + -------------------------------- hsc2hs -------------------------------- + , package hsc2hs ? + builder (Cabal Flags) ? arg "in-ghc-tree" + + ------------------------------ integerGmp ------------------------------ + , package integerGmp ? mconcat + [ builder Cc ? arg includeGmp + + , builder (Cabal Setup) ? mconcat + [ -- TODO: This should respect some settings flag "InTreeGmp". + -- Depending on @IncludeDir@ and @LibDir@ is bound to fail, since + -- these are only set if the configure script was explicilty + -- called with GMP include and lib dirs. Their absense as such + -- does not imply @in-tree-gmp@. + -- (null gmpIncludeDir && null gmpLibDir) ? + -- arg "--configure-option=--with-intree-gmp" + arg ("--configure-option=CFLAGS=" ++ includeGmp) + , arg ("--gcc-options=" ++ includeGmp) ] ] + + ---------------------------------- rts --------------------------------- + , package rts ? rtsPackageArgs -- RTS deserves a separate function + + -------------------------------- runGhc -------------------------------- + , package runGhc ? + builder Ghc ? input "//Main.hs" ? + (\version -> ["-cpp", "-DVERSION=" ++ show version]) <$> getSetting ProjectVersion + + --------------------------------- text --------------------------------- + -- The package @text@ is rather tricky. It's a boot library, and it + -- tries to determine on its own if it should link against @integer-gmp@ + -- or @integer-simple@. For Stage0, we need to use the integer library + -- that the bootstrap compiler has (since @interger@ is not a boot + -- library) and therefore we copy it over into the Stage0 package-db. + -- Maybe we should stop doing this? And subsequently @text@ for Stage1 + -- detects the same integer library again, even though we don't build it + -- in Stage1, and at that point the configuration is just wrong. + , package text ? + builder (Cabal Flags) ? notStage0 ? intLib == integerSimple ? + pure [ "+integer-simple", "-bytestring-builder"] ] + +-- | RTS-specific command line arguments. +rtsPackageArgs :: Args +rtsPackageArgs = package rts ? do + projectVersion <- getSetting ProjectVersion + hostPlatform <- getSetting HostPlatform + hostArch <- getSetting HostArch + hostOs <- getSetting HostOs + hostVendor <- getSetting HostVendor + buildPlatform <- getSetting BuildPlatform + buildArch <- getSetting BuildArch + buildOs <- getSetting BuildOs + buildVendor <- getSetting BuildVendor + targetPlatform <- getSetting TargetPlatform + targetArch <- getSetting TargetArch + targetOs <- getSetting TargetOs + targetVendor <- getSetting TargetVendor + ghcUnreg <- expr $ yesNo <$> flag GhcUnregisterised + ghcEnableTNC <- expr $ yesNo <$> ghcEnableTablesNextToCode + rtsWays <- getRtsWays + way <- getWay + path <- getBuildPath + top <- expr topDirectory + libffiName <- expr libffiLibraryName + ffiIncludeDir <- getSetting FfiIncludeDir + ffiLibraryDir <- getSetting FfiLibDir + let cArgs = mconcat + [ arg "-Irts" + , rtsWarnings + , arg $ "-I" ++ path + , flag UseSystemFfi ? arg ("-I" ++ ffiIncludeDir) + , arg $ "-DRtsWay=\"rts_" ++ show way ++ "\"" + -- Set the namespace for the rts fs functions + , arg $ "-DFS_NAMESPACE=rts" + , arg $ "-DCOMPILING_RTS" + -- RTS *must* be compiled with optimisations. The INLINE_HEADER macro + -- requires that functions are inlined to work as expected. Inlining + -- only happens for optimised builds. Otherwise we can assume that + -- there is a non-inlined variant to use instead. But RTS does not + -- provide non-inlined alternatives and hence needs the function to + -- be inlined. See https://github.com/snowleopard/hadrian/issues/90. + , arg "-O2" + , arg "-fomit-frame-pointer" + , arg "-g" + + , Debug `wayUnit` way ? pure [ "-DDEBUG" + , "-fno-omit-frame-pointer" + , "-g" ] + , way `elem` [debug, debugDynamic] ? arg "-DTICKY_TICKY" + , Profiling `wayUnit` way ? arg "-DPROFILING" + , Threaded `wayUnit` way ? arg "-DTHREADED_RTS" + + , inputs ["//RtsMessages.c", "//Trace.c"] ? + arg ("-DProjectVersion=" ++ show projectVersion) + + , input "//RtsUtils.c" ? pure + [ "-DProjectVersion=" ++ show projectVersion + , "-DHostPlatform=" ++ show hostPlatform + , "-DHostArch=" ++ show hostArch + , "-DHostOS=" ++ show hostOs + , "-DHostVendor=" ++ show hostVendor + , "-DBuildPlatform=" ++ show buildPlatform + , "-DBuildArch=" ++ show buildArch + , "-DBuildOS=" ++ show buildOs + , "-DBuildVendor=" ++ show buildVendor + , "-DTargetPlatform=" ++ show targetPlatform + , "-DTargetArch=" ++ show targetArch + , "-DTargetOS=" ++ show targetOs + , "-DTargetVendor=" ++ show targetVendor + , "-DGhcUnregisterised=" ++ show ghcUnreg + , "-DGhcEnableTablesNextToCode=" ++ show ghcEnableTNC ] + + -- We're after pur performance here. So make sure fast math and + -- vectorization is enabled. + , input "//xxhash.c" ? pure + [ "-O3" + , "-ffast-math" + , "-ftree-vectorize" ] + + , inputs ["//Evac.c", "//Evac_thr.c"] ? arg "-funroll-loops" + + , speedHack ? + inputs [ "//Evac.c", "//Evac_thr.c" + , "//Scav.c", "//Scav_thr.c" + , "//Compact.c", "//GC.c" ] ? arg "-fno-PIC" + -- @-static@ is necessary for these bits, as otherwise the NCG + -- generates dynamic references. + , speedHack ? + inputs [ "//Updates.c", "//StgMiscClosures.c" + , "//PrimOps.c", "//Apply.c" + , "//AutoApply.c" ] ? pure ["-fno-PIC", "-static"] + + -- inlining warnings happen in Compact + , inputs ["//Compact.c"] ? arg "-Wno-inline" + + -- emits warnings about call-clobbered registers on x86_64 + , inputs [ "//RetainerProfile.c", "//StgCRun.c" + , "//win32/ConsoleHandler.c", "//win32/ThrIOManager.c"] ? arg "-w" + -- The above warning suppression flags are a temporary kludge. + -- While working on this module you are encouraged to remove it and fix + -- any warnings in the module. See: + -- http://ghc.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings + + , (not <$> flag GccIsClang) ? + inputs ["//Compact.c"] ? arg "-finline-limit=2500" + + , input "//RetainerProfile.c" ? flag GccIsClang ? + arg "-Wno-incompatible-pointer-types" + , windowsHost ? arg ("-DWINVER=" ++ windowsVersion) + + -- libffi's ffi.h triggers various warnings + , inputs [ "//Interpreter.c", "//Storage.c", "//Adjustor.c" ] ? + arg "-Wno-strict-prototypes" + , inputs ["//Interpreter.c", "//Adjustor.c", "//sm/Storage.c"] ? + anyTargetArch ["powerpc"] ? arg "-Wno-undef" ] + + mconcat + [ builder (Cabal Flags) ? mconcat + [ any (wayUnit Profiling) rtsWays ? arg "profiling" + , any (wayUnit Debug) rtsWays ? arg "debug" + , any (wayUnit Logging) rtsWays ? arg "logging" + ] + , builder (Cc FindCDependencies) ? cArgs + , builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs + , builder Ghc ? arg "-Irts" + + , builder HsCpp ? pure + [ "-DTOP=" ++ show top + , "-DFFI_INCLUDE_DIR=" ++ show ffiIncludeDir + , "-DFFI_LIB_DIR=" ++ show ffiLibraryDir + , "-DFFI_LIB=" ++ show libffiName ] + + , builder HsCpp ? flag HaveLibMingwEx ? arg "-DHAVE_LIBMINGWEX" ] + +-- Compile various performance-critical pieces *without* -fPIC -dynamic +-- even when building a shared library. If we don't do this, then the +-- GC runs about 50% slower on x86 due to the overheads of PIC. The +-- cost of doing this is a little runtime linking and less sharing, but +-- not much. +-- +-- On x86_64 this doesn't work, because all objects in a shared library +-- must be compiled with -fPIC (since the 32-bit relocations generated +-- by the default small memory can't be resolved at runtime). So we +-- only do this on i386. +-- +-- This apparently doesn't work on OS X (Darwin) nor on Solaris. +-- On Darwin we get errors of the form +-- +-- ld: absolute addressing (perhaps -mdynamic-no-pic) used in _stg_ap_0_fast +-- from rts/dist/build/Apply.dyn_o not allowed in slidable image +-- +-- and lots of these warnings: +-- +-- ld: warning codegen in _stg_ap_pppv_fast (offset 0x0000005E) prevents image +-- from loading in dyld shared cache +-- +-- On Solaris we get errors like: +-- +-- Text relocation remains referenced +-- against symbol offset in file +-- .rodata (section) 0x11 rts/dist/build/Apply.dyn_o +-- ... +-- ld: fatal: relocations remain against allocatable but non-writable sections +-- collect2: ld returned 1 exit status +speedHack :: Action Bool +speedHack = do + i386 <- anyTargetArch ["i386"] + goodOS <- not <$> anyTargetOs ["darwin", "solaris2"] + return $ i386 && goodOS + +-- See @rts/ghc.mk@. +rtsWarnings :: Args +rtsWarnings = mconcat + [ arg "-Wall" + , arg "-Wextra" + , arg "-Wstrict-prototypes" + , arg "-Wmissing-prototypes" + , arg "-Wmissing-declarations" + , arg "-Winline" + , arg "-Waggregate-return" + , arg "-Wpointer-arith" + , arg "-Wmissing-noreturn" + , arg "-Wnested-externs" + , arg "-Wredundant-decls" + , arg "-Wundef" + , arg "-fno-strict-aliasing" ] + +-- These numbers can be found at: +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx +-- If we're compiling on windows, enforce that we only support Vista SP1+ +-- Adding this here means it doesn't have to be done in individual .c files +-- and also centralizes the versioning. +-- | Minimum supported Windows version. +windowsVersion :: String +windowsVersion = "0x06000100" diff --git a/hadrian/src/Settings/Warnings.hs b/hadrian/src/Settings/Warnings.hs new file mode 100644 index 0000000000..5a9e8311db --- /dev/null +++ b/hadrian/src/Settings/Warnings.hs @@ -0,0 +1,57 @@ +module Settings.Warnings (defaultGhcWarningsArgs, warningArgs) where + +import Expression +import Oracles.Flag +import Oracles.Setting +import Packages +import Settings + +-- See @mk/warnings.mk@ for warning-related arguments in the Make build system. + +-- | Default Haskell warning-related arguments. +defaultGhcWarningsArgs :: Args +defaultGhcWarningsArgs = mconcat + [ notStage0 ? arg "-Wnoncanonical-monad-instances" + , (not <$> flag GccIsClang) ? mconcat + [ (not <$> windowsHost ) ? arg "-optc-Werror=unused-but-set-variable" + , arg "-optc-Wno-error=inline" ] + , flag GccIsClang ? arg "-optc-Wno-unknown-pragmas" ] + +-- | Package-specific warnings-related arguments, mostly suppressing various warnings. +warningArgs :: Args +warningArgs = builder Ghc ? do + isIntegerSimple <- (== integerSimple) <$> getIntegerPackage + mconcat + [ stage0 ? mconcat + [ libraryPackage ? pure [ "-fno-warn-deprecated-flags" ] + , package terminfo ? pure [ "-fno-warn-unused-imports" ] + , package transformers ? pure [ "-fno-warn-unused-matches" + , "-fno-warn-unused-imports" ] ] + , notStage0 ? mconcat + [ libraryPackage ? pure [ "-Wno-deprecated-flags" ] + , package base ? pure [ "-Wno-trustworthy-safe" ] + , package binary ? pure [ "-Wno-deprecations" ] + , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] + , package compiler ? pure [ "-Wcpp-undef" ] + , package directory ? pure [ "-Wno-unused-imports" ] + , package ghc ? pure [ "-Wcpp-undef" ] + , package ghcPrim ? pure [ "-Wno-trustworthy-safe" ] + , package haddock ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" ] + , package haskeline ? pure [ "-Wno-deprecations" + , "-Wno-unused-imports" + , "-Wno-redundant-constraints" + , "-Wno-simplifiable-class-constraints" ] + , package pretty ? pure [ "-Wno-unused-imports" ] + , package primitive ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" ] + , package rts ? pure [ "-Wcpp-undef" ] + , package terminfo ? pure [ "-Wno-unused-imports" ] + , isIntegerSimple ? + package text ? pure [ "-Wno-unused-imports" ] + , package transformers ? pure [ "-Wno-unused-matches" + , "-Wno-unused-imports" + , "-Wno-redundant-constraints" + , "-Wno-orphans" ] + , package win32 ? pure [ "-Wno-trustworthy-safe" ] + , package xhtml ? pure [ "-Wno-unused-imports" ] ] ] diff --git a/hadrian/src/Stage.hs b/hadrian/src/Stage.hs new file mode 100644 index 0000000000..7c9405c2b8 --- /dev/null +++ b/hadrian/src/Stage.hs @@ -0,0 +1,31 @@ +module Stage (Stage (..), stageString) where + +import Development.Shake.Classes +import GHC.Generics + +-- | A stage refers to a certain compiler in GHC's build process. +-- +-- * Stage 0 is built with the bootstrapping compiler, i.e. the one already +-- installed on the user's system. The compiler that is produced during +-- stage 0 is called /stage 1 compiler/. +-- +-- * Stage 1 is built using the stage 1 compiler and all GHC sources. The result +-- is called /stage 2 compiler/ and it has all features of the new GHC. +-- +-- * Stage 2 is built using the stage 2 compiler. The result is a compiler +-- fully "built by itself", commonly referred to as /bootstrapping/. +-- +-- * Stage 3 is built as a self test. The resulting compiler should have +-- the same object code as the one built in stage 2, which is a good test +-- for the compiler. Since it serves no other purpose than that, the stage 3 +-- build is usually omitted in the build process. +data Stage = Stage0 | Stage1 | Stage2 | Stage3 + deriving (Show, Eq, Ord, Enum, Generic, Bounded) + +instance Binary Stage +instance Hashable Stage +instance NFData Stage + +-- | Prettyprint a 'Stage'. +stageString :: Stage -> String +stageString stage = "stage" ++ show (fromEnum stage) diff --git a/hadrian/src/Target.hs b/hadrian/src/Target.hs new file mode 100644 index 0000000000..30c8d98d14 --- /dev/null +++ b/hadrian/src/Target.hs @@ -0,0 +1,26 @@ +module Target ( + Target, target, context, builder, inputs, outputs, trackArgument, + module Builder + ) where + +import Data.Char +import Data.List.Extra + +import qualified Hadrian.Target as H +import Hadrian.Target hiding (Target) + +import Builder +import Context + +type Target = H.Target Context Builder + +-- | Some arguments do not affect build results and therefore do not need to be +-- tracked by the build system. A notable example is "-jN" that controls Make's +-- parallelism. Given a 'Target' and an argument, this function should return +-- 'True' only if the argument needs to be tracked. +trackArgument :: Target -> String -> Bool +trackArgument target arg = case builder target of + (Make _) -> not $ threadArg arg + _ -> True + where + threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="] diff --git a/hadrian/src/UserSettings.hs b/hadrian/src/UserSettings.hs new file mode 100644 index 0000000000..9246806991 --- /dev/null +++ b/hadrian/src/UserSettings.hs @@ -0,0 +1,54 @@ +-- If you want to customise your build you should copy this file from +-- hadrian/src/UserSettings.hs to hadrian/UserSettings.hs and edit your copy. +-- If you don't copy the file your changes will be tracked by git and you can +-- accidentally commit them. +module UserSettings ( + userFlavours, userPackages, verboseCommand, buildProgressColour, + successColour, stage1Only + ) where + +import Flavour +import Expression +import {-# SOURCE #-} Settings.Default + +-- See doc/user-settings.md for instructions. +-- Please update doc/user-settings.md when committing changes to this file. + +-- | User-defined build flavours. See 'userFlavour' as an example. +userFlavours :: [Flavour] +userFlavours = [userFlavour] -- Add more build flavours if need be. + +-- | This is an example user-defined build flavour. Feel free to modify it and +-- use by passing @--flavour=user@ from the command line. +userFlavour :: Flavour +userFlavour = defaultFlavour { name = "user" } -- Modify other settings here. + +-- | Add user-defined packages. Note, this only lets Hadrian know about the +-- existence of a new package; to actually build it you need to create a new +-- build flavour, modifying the list of packages that are built by default. +userPackages :: [Package] +userPackages = [] + +-- | Set to 'True' to print full command lines during the build process. Note: +-- this is a 'Predicate', hence you can enable verbose output only for certain +-- targets, e.g.: @verboseCommand = package ghcPrim@. +verboseCommand :: Predicate +verboseCommand = do + verbosity <- expr getVerbosity + return $ verbosity >= Loud + +-- | Set colour for build progress messages (e.g. executing a build command). +buildProgressColour :: BuildProgressColour +buildProgressColour = mkBuildProgressColour (Dull Magenta) + +-- | Set colour for success messages (e.g. a package is built successfully). +successColour :: SuccessColour +successColour = mkSuccessColour (Dull Green) + +-- TODO: Set this flag from the command line. +-- | Set this flag to 'True' to disable building Stage2 GHC and Stage2 utilities +-- such as @haddock@. All Stage0 and Stage1 libraries will still be built. +-- Also see Note [No stage2 packages when CrossCompiling or Stage1Only] in the +-- top-level @ghc.mk@. +stage1Only :: Bool +stage1Only = False diff --git a/hadrian/src/Utilities.hs b/hadrian/src/Utilities.hs new file mode 100644 index 0000000000..7fe6a89dae --- /dev/null +++ b/hadrian/src/Utilities.hs @@ -0,0 +1,89 @@ +module Utilities ( + build, buildWithResources, buildWithCmdOptions, + askWithResources, + runBuilder, runBuilderWith, + needLibrary, contextDependencies, stage1Dependencies, libraryTargets, + topsortPackages, cabalDependencies + ) where + +import qualified Hadrian.Builder as H +import Hadrian.Haskell.Cabal +import Hadrian.Haskell.Cabal.Type +import Hadrian.Utilities + +import Context +import Expression hiding (stage) +import Settings +import Target + +build :: Target -> Action () +build target = H.build target getArgs + +buildWithResources :: [(Resource, Int)] -> Target -> Action () +buildWithResources rs target = H.buildWithResources rs target getArgs + +buildWithCmdOptions :: [CmdOption] -> Target -> Action () +buildWithCmdOptions opts target = H.buildWithCmdOptions opts target getArgs + +askWithResources :: [(Resource, Int)] -> Target -> Action String +askWithResources rs target = H.askWithResources rs target getArgs + +-- TODO: Cache the computation. +-- | Given a 'Context' this 'Action' looks up the package dependencies and wraps +-- the results in appropriate contexts. The only subtlety here is that we never +-- depend on packages built in 'Stage2' or later, therefore the stage of the +-- resulting dependencies is bounded from above at 'Stage1'. To compute package +-- dependencies we transitively scan Cabal files using 'pkgDependencies' defined +-- in "Hadrian.Haskell.Cabal". +contextDependencies :: Context -> Action [Context] +contextDependencies Context {..} = do + depPkgs <- go [package] + return [ Context depStage pkg way | pkg <- depPkgs, pkg /= package ] + where + depStage = min stage Stage1 + go pkgs = do + deps <- concatMapM step pkgs + let newPkgs = nubOrd $ sort (deps ++ pkgs) + if pkgs == newPkgs then return pkgs else go newPkgs + step pkg = do + deps <- pkgDependencies pkg + active <- sort <$> stagePackages depStage + return $ intersectOrd (compare . pkgName) active deps + +cabalDependencies :: Context -> Action [String] +cabalDependencies ctx = interpretInContext ctx $ getContextData depIds + +-- | Lookup dependencies of a 'Package' in the @vanilla Stage1 context@. +stage1Dependencies :: Package -> Action [Package] +stage1Dependencies = + fmap (map Context.package) . contextDependencies . vanillaContext Stage1 + +-- | Given a library 'Package' this action computes all of its targets. See +-- 'packageTargets' for the explanation of the @includeGhciLib@ parameter. +libraryTargets :: Bool -> Context -> Action [FilePath] +libraryTargets includeGhciLib context = do + libFile <- pkgLibraryFile context + ghciLib <- pkgGhciLibraryFile context + ghci <- if includeGhciLib + then interpretInContext context $ getContextData buildGhciLib + else return False + return $ [ libFile ] ++ [ ghciLib | ghci ] + +-- | Coarse-grain 'need': make sure all given libraries are fully built. +needLibrary :: [Context] -> Action () +needLibrary cs = need =<< concatMapM (libraryTargets True) cs + +-- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344. +-- | Topological sort of packages according to their dependencies. +topsortPackages :: [Package] -> Action [Package] +topsortPackages pkgs = do + elems <- mapM (\p -> (p,) <$> stage1Dependencies p) pkgs + return $ map fst $ topSort elems + where + annotateInDeg es e = + (foldr (\e' s -> if fst e' `elem` snd e then s + 1 else s) (0 :: Int) es, e) + topSort [] = [] + topSort es = + let annotated = map (annotateInDeg es) es + inDegZero = map snd $ filter ((== 0). fst) annotated + in inDegZero ++ topSort (es \\ inDegZero) diff --git a/hadrian/src/Way.hs b/hadrian/src/Way.hs new file mode 100644 index 0000000000..2375a122a7 --- /dev/null +++ b/hadrian/src/Way.hs @@ -0,0 +1,81 @@ +module Way ( + WayUnit (..), Way, wayUnit, addWayUnit, removeWayUnit, wayFromUnits, allWays, + + vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging, + threadedDebug, threadedProfiling, threadedLogging, threadedDynamic, + threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic, + threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic, + + wayPrefix, waySuffix, hisuf, osuf, hcsuf, obootsuf, hibootsuf, ssuf + ) where + +import Way.Type + +-- | Build default _vanilla_ way. +vanilla :: Way +vanilla = wayFromUnits [] + +-- | Build with profiling. +profiling :: Way +profiling = wayFromUnits [Profiling] + +-- | Build with dynamic linking. +dynamic :: Way +dynamic = wayFromUnits [Dynamic] + +-- | Build with profiling and dynamic linking. +profilingDynamic :: Way +profilingDynamic = wayFromUnits [Profiling, Dynamic] + +-- RTS only ways below. See compiler/main/DynFlags.hs. +-- | Build RTS with event logging. +logging :: Way +logging = wayFromUnits [Logging] + +-- | Build multithreaded RTS. +threaded :: Way +threaded = wayFromUnits [Threaded] + +-- | Build RTS with debug information. +debug :: Way +debug = wayFromUnits [Debug] + +-- | Various combinations of RTS only ways. +threadedDebug, threadedProfiling, threadedLogging, threadedDynamic, + threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic, + threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic :: Way +threadedDebug = wayFromUnits [Threaded, Debug] +threadedProfiling = wayFromUnits [Threaded, Profiling] +threadedLogging = wayFromUnits [Threaded, Logging] +threadedDynamic = wayFromUnits [Threaded, Dynamic] +threadedDebugProfiling = wayFromUnits [Threaded, Debug, Profiling] +threadedDebugDynamic = wayFromUnits [Threaded, Debug, Dynamic] +threadedProfilingDynamic = wayFromUnits [Threaded, Profiling, Dynamic] +threadedLoggingDynamic = wayFromUnits [Threaded, Logging, Dynamic] +debugProfiling = wayFromUnits [Debug, Profiling] +debugDynamic = wayFromUnits [Debug, Dynamic] +loggingDynamic = wayFromUnits [Logging, Dynamic] + +-- | All ways supported by the build system. +allWays :: [Way] +allWays = + [ vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging + , threadedDebug, threadedProfiling, threadedLogging, threadedDynamic + , threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic + , threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic ] + +wayPrefix :: Way -> String +wayPrefix way | way == vanilla = "" + | otherwise = show way ++ "_" + +waySuffix :: Way -> String +waySuffix way | way == vanilla = "" + | otherwise = "_" ++ show way + +osuf, ssuf, hisuf, hcsuf, obootsuf, hibootsuf :: Way -> String +osuf = (++ "o" ) . wayPrefix +ssuf = (++ "s" ) . wayPrefix +hisuf = (++ "hi" ) . wayPrefix +hcsuf = (++ "hc" ) . wayPrefix +obootsuf = (++ "o-boot" ) . wayPrefix +hibootsuf = (++ "hi-boot") . wayPrefix diff --git a/hadrian/src/Way/Type.hs b/hadrian/src/Way/Type.hs new file mode 100644 index 0000000000..4055ff4798 --- /dev/null +++ b/hadrian/src/Way/Type.hs @@ -0,0 +1,88 @@ +module Way.Type where + +import Data.IntSet (IntSet) +import qualified Data.IntSet as Set +import Data.List +import Data.Maybe +import Development.Shake.Classes +import Hadrian.Utilities + +-- Note: order of constructors is important for compatibility with the old build +-- system, e.g. we want "thr_p", not "p_thr" (see instance Show Way). +-- | A 'WayUnit' is a single way of building source code, for example with +-- profiling enabled, or dynamically linked. +data WayUnit = Threaded + | Debug + | Profiling + | Logging + | Dynamic + deriving (Bounded, Enum, Eq, Ord) + +-- TODO: get rid of non-derived Show instances +instance Show WayUnit where + show unit = case unit of + Threaded -> "thr" + Debug -> "debug" + Profiling -> "p" + Logging -> "l" + Dynamic -> "dyn" + +instance Read WayUnit where + readsPrec _ s = [(unit, "") | unit <- [minBound ..], show unit == s] + +-- | Collection of 'WayUnit's that stands for the different ways source code +-- is to be built. +newtype Way = Way IntSet + +instance Binary Way where + put = put . show + get = fmap read get + +instance Hashable Way where + hashWithSalt salt = hashWithSalt salt . show + +instance NFData Way where + rnf (Way s) = s `seq` () + +-- | Construct a 'Way' from multiple 'WayUnit's. Inverse of 'wayToUnits'. +wayFromUnits :: [WayUnit] -> Way +wayFromUnits = Way . Set.fromList . map fromEnum + +-- | Split a 'Way' into its 'WayUnit' building blocks. +-- Inverse of 'wayFromUnits'. +wayToUnits :: Way -> [WayUnit] +wayToUnits (Way set) = map toEnum . Set.elems $ set + +-- | Check whether a 'Way' contains a certain 'WayUnit'. +wayUnit :: WayUnit -> Way -> Bool +wayUnit unit (Way set) = fromEnum unit `Set.member` set + +-- | Add a 'WayUnit' to a 'Way' +addWayUnit :: WayUnit -> Way -> Way +addWayUnit unit (Way set) = Way . Set.insert (fromEnum unit) $ set + +-- | Remove a 'WayUnit' from 'Way'. +removeWayUnit :: WayUnit -> Way -> Way +removeWayUnit unit (Way set) = Way . Set.delete (fromEnum unit) $ set + +instance Show Way where + show way = if null tag then "v" else tag + where + tag = intercalate "_" . map show . wayToUnits $ way + +instance Read Way where + readsPrec _ s = if s == "v" then [(wayFromUnits [], "")] else result + where + uniqueReads token = case reads token of + [(unit, "")] -> Just unit + _ -> Nothing + units = map uniqueReads . words . replaceEq '_' ' ' $ s + result = if Nothing `elem` units + then [] + else [(wayFromUnits . map fromJust $ units, "")] + +instance Eq Way where + Way a == Way b = a == b + +instance Ord Way where + compare (Way a) (Way b) = compare a b diff --git a/hadrian/stack.yaml b/hadrian/stack.yaml new file mode 100644 index 0000000000..d379133384 --- /dev/null +++ b/hadrian/stack.yaml @@ -0,0 +1,30 @@ +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-12.10 + +# Local packages, usually specified by relative directory name +packages: +- '.' +- '../libraries/Cabal/Cabal' +- '../libraries/text' + +# This is necessary to build until happy's version bounds are updated to work +# with the new Cabal version. Stack's error message explains the issue: +# +# In the dependencies for happy-1.19.9: +# Cabal-2.3.0.0 from stack configuration does not match <2.2 (latest matching version is 2.0.1.1) +# needed due to hadrian-0.1.0.0 -> happy-1.19.9 +# +# TODO: Remove this once it's no longer necessary +allow-newer: true + +nix: + enable: false + packages: + - autoconf + - automake + - gcc + - git + - ncurses + - perl |