diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2017-11-09 17:50:42 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-11-09 17:50:42 -0500 |
| commit | 977305346cffad70f0977467153cce52b2d1ae0b (patch) | |
| tree | 1f2d56eb4d5a21bafcfedf9ce201a97490bc4ec7 | |
| parent | bdd2d2862e248948efafa8ba4219e94825ddf21a (diff) | |
| parent | 5cee48036ed69ae298a599d43cf72e0fe73e3b4e (diff) | |
| download | haskell-977305346cffad70f0977467153cce52b2d1ae0b.tar.gz | |
Merge initial Hadrian snapshot
We will continue to pull in squashed snapshots periodically until we
eventually discontinue development in Hadrian's GitHub repository.
112 files changed, 8898 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..e2455b2da3 --- /dev/null +++ b/hadrian/.travis.yml @@ -0,0 +1,90 @@ +sudo: true +matrix: + include: + - os: linux + env: MODE="--flavour=quickest inplace/bin/ghc-stage1" + compiler: "GHC 8.0.2" + addons: + apt: + packages: + - ghc-8.0.2 + - cabal-install-2.0 + - zlib1g-dev + sources: hvr-ghc + + before_install: + - PATH="/opt/ghc/8.0.2/bin:$PATH" + - PATH="/opt/cabal/2.0/bin:$PATH" + + script: + # Run internal Hadrian tests + - ./build.sh selftest + + # Build GHC + - ./build.sh -j $MODE --no-progress --progress-colour=never --profile=- + + - os: linux + env: MODE="--flavour=quickest --integer-simple" + compiler: "GHC 8.2.1" + addons: + apt: + packages: + - ghc-8.2.1 + - cabal-install-1.22 + - zlib1g-dev + sources: hvr-ghc + + before_install: + - PATH="/opt/ghc/8.2.1/bin:$PATH" + - PATH="/opt/cabal/1.22/bin:$PATH" + + script: + # Build GHC + - ./build.sh -j $MODE --no-progress --progress-colour=never --profile=- + + # Test GHC binary + - cd .. + - inplace/bin/ghc-stage2 -e 1+2 + + - os: osx + osx_image: xcode8 + env: MODE="--flavour=quickest --integer-simple inplace/bin/ghc-stage1" + before_install: + - brew update + - brew install ghc cabal-install python3 + + script: + # Due to timeout limit of OS X build on Travis CI, + # we will ignore selftest and build only stage1 + - ./build.sh -j $MODE --no-progress --progress-colour=never --profile=- + +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 + + # 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 + - mkdir ghc/hadrian + - mv .git ghc/hadrian + - cd ghc/hadrian + - git reset --hard HEAD + +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..eb3dd86be6 --- /dev/null +++ b/hadrian/README.md @@ -0,0 +1,194 @@ +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][paper] and this [Haskell eXchange 2016 talk][talk]. + +The new build system can work side-by-side with the existing build system. Note, there is +some interaction between them: they put (some) build results in the same directories, +e.g. the resulting GHC is `inplace/bin/ghc-stage2`. + +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 runs the `boot` and `configure` scripts automatically when +needed. Use `--skip-configure` to suppress this behaviour (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 the following packages: +`ansi-terminal extra mtl quickcheck shake`. + +* 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: +* `--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). + +* `--skip-configure`: use this flag to suppress the default behaviour of Hadrian that +runs the `boot` and `configure` scripts automatically when needed, so that you don't have +to remember to run them manually. With `--skip-configure` you will need to manually run: + ```bash + ./boot + ./configure # On Windows run ./configure --enable-tarballs-autodownload + ``` + as you normally do when using `make`. Beware, by default Hadrian may do network I/O on +Windows to download necessary tarballs, which may sometimes be undesirable; `--skip-configure` +is your friend in such cases. + +* `--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 sdist-ghc`. + +#### Installation + +To build and install GHC artifacts, run `build install`. + +By default, GHC will be installed to the specified _prefix_ path on your system, +relative to the root of the file system. For example on UNIX, GHC will be installed +to `/usr/local/bin`. By setting the command line flag `--install-destdir=[DESTDIR]`, +you can install GHC to path `DESTDIR/<prefix>` instead. Make sure you use correct +absolute path as `DESTDIR` on Windows, e.g. `C:/path`, which installs GHC +into `C:/path/usr/local`. + +#### 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]). + +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 +[paper]: https://www.staff.ncl.ac.uk/andrey.mokhov/Hadrian.pdf +[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..fbedf8f179 --- /dev/null +++ b/hadrian/appveyor.yml @@ -0,0 +1,39 @@ +clone_folder: "c:\\ghc\\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 + + # Fetch GHC sources into c:\ghc + # Note: AppVeyor has already cloned Hadrian into c:\ghc\hadrian, so it's tricky + - cd .. + - git init + - git remote add origin git://git.haskell.org/ghc.git + - git pull --recurse-submodules origin master + - git submodule update --init --recursive --quiet + + # Install all Hadrian and GHC build dependencies + - cd hadrian + - stack setup > nul + - appveyor-retry stack exec -- pacman -S autoconf automake-wrapper make patch python tar --noconfirm + +build_script: + # Build Hadrian + - stack build alex happy # Otherwise 'build' fails on AppVeyor + + # Run internal Hadrian tests + - build selftest + + # Build GHC + - build -j --flavour=quickest --no-progress --progress-colour=never --profile=- + + # Test GHC binary + - cd .. + - inplace\bin\ghc-stage2 -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.sh b/hadrian/build.cabal.sh new file mode 100644 index 0000000000..d2bdb857e1 --- /dev/null +++ b/hadrian/build.cabal.sh @@ -0,0 +1,74 @@ +#!/usr/bin/env bash + +CABAL=cabal + +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" + +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 1 ]; then + # New enough Cabal version detected, so let's use the superior new-build + new-run + # modes. Note that pre-2.1 Cabal does not support passing additional parameters + # to the executable (hadrian) after the separator '--', see #438. + + "$CABAL" new-build --disable-profiling --disable-documentation -j exe:hadrian + "$CABAL" new-run hadrian -- \ + --lint \ + --directory "$absoluteRoot/.." \ + "$@" + +else + # The logic below is quite fragile, but it's better than nothing for pre-2.1 Cabal. + echo "Old pre cabal 2.1 version detected. Falling back to legacy 'cabal sandbox' mode." + + # Initialize sandbox if necessary + if ! ( "$CABAL" sandbox hc-pkg list > /dev/null 2>&1); then + "$CABAL" sandbox init + "$CABAL" sandbox add-source ../libraries/Cabal/Cabal + "$CABAL" install \ + --dependencies-only \ + --disable-library-profiling \ + --disable-shared + fi + + "$CABAL" run hadrian -- \ + --lint \ + --directory "$absoluteRoot/.." \ + "$@" +fi diff --git a/hadrian/build.global-db.bat b/hadrian/build.global-db.bat new file mode 100644 index 0000000000..0d6a6968a8 --- /dev/null +++ b/hadrian/build.global-db.bat @@ -0,0 +1,32 @@ +@echo off +setlocal +cd %~dp0 +mkdir bin 2> nul + +set ghcArgs=--make ^ + -Wall ^ + -fno-warn-name-shadowing ^ + -XRecordWildCards ^ + src\Main.hs ^ + -threaded ^ + -isrc ^ + -i..\libraries\Cabal\Cabal ^ + -rtsopts ^ + -with-rtsopts=-I0 ^ + -outputdir=bin ^ + -j ^ + -O ^ + -o bin\hadrian + +set hadrianArgs=--lint ^ + --directory ^ + ".." ^ + %* + +ghc %ghcArgs% + +if %ERRORLEVEL% NEQ 0 EXIT /B %ERRORLEVEL% + +rem Unset GHC_PACKAGE_PATH variable, as otherwise ghc-cabal complains +set GHC_PACKAGE_PATH= +bin\hadrian %hadrianArgs% diff --git a/hadrian/build.global-db.sh b/hadrian/build.global-db.sh new file mode 100755 index 0000000000..5f1579becd --- /dev/null +++ b/hadrian/build.global-db.sh @@ -0,0 +1,52 @@ +#!/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" +} + +root="$(dirname "$(rl "$0")")" + +mkdir -p "$root/bin" + +ghc \ + "$root/src/Main.hs" \ + -Wall \ + -fno-warn-name-shadowing \ + -XRecordWildCards \ + -i"$root/src" \ + -i"$root/../libraries/Cabal/Cabal" \ + -rtsopts \ + -with-rtsopts=-I0 \ + -threaded \ + -outputdir="$root/bin" \ + -j -O \ + -o "$root/bin/hadrian" + +"$root/bin/hadrian" \ + --lint \ + --directory "$root/.." \ + "$@"
\ No newline at end of file diff --git a/hadrian/build.sh b/hadrian/build.sh new file mode 100755 index 0000000000..ad502b3c49 --- /dev/null +++ b/hadrian/build.sh @@ -0,0 +1,35 @@ +#!/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" +} + +root="$(dirname "$(rl "$0")")" + +# By default on Linux/MacOS we build Hadrian using Cabal +chmod a+x "$root/build.cabal.sh" +(. "$root/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..1ef81ca2d0 --- /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..913a2b48bf --- /dev/null +++ b/hadrian/cfg/system.config.in @@ -0,0 +1,141 @@ +# This file is processed by the configure script. +# See hadrian/src/UserSettings.hs for user-defined settings. +#=========================================================== + +# Paths to builders: +#=================== + +alex = @AlexCmd@ +ar = @ArCmd@ +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@ +ln-s = @LN_S@ +xelatex = @XELATEX@ + +# Information about builders: +#============================ + +ar-supports-at-file = @ArSupportsAtFile@ +cc-clang-backend = @CC_CLANG_BACKEND@ +cc-llvm-backend = @CC_LLVM_BACKEND@ +gcc-is-clang = @GccIsClang@ +gcc-lt-34 = @GccLT34@ +gcc-lt-44 = @GccLT44@ +gcc-lt-46 = @GccLT46@ +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@ + +# Installation: +#======================= + +install-prefix = @prefix@ +install-bindir = @prefix@/bin +install-libdir = @prefix@/lib +install-datarootdir = @prefix@/share + +install = @INSTALL@ +install-program = @INSTALL@ -m 755 +install-script = @INSTALL@ -m 755 +install-data = @INSTALL@ -m 644 +install-dir = @INSTALL@ -m 755 -d diff --git a/hadrian/circle.yml b/hadrian/circle.yml new file mode 100644 index 0000000000..a386d72da8 --- /dev/null +++ b/hadrian/circle.yml @@ -0,0 +1,41 @@ +machine: + xcode: + version: 8.0 + environment: + MODE: --flavour=quickest --integer-simple + +dependencies: + override: + - brew update + - brew install ghc cabal-install python3 + - cabal update + - cabal install alex happy ansi-terminal mtl shake quickcheck + cache_directories: + - $HOME/.cabal + - $HOME/.ghc + +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 + + - mkdir ghc/hadrian + # 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 + + # XXX: export PATH doesn't work well either, so we use inline env + # Self test + - PATH=$HOME/.cabal/bin:$PATH ghc/hadrian/build.sh selftest + + # Build GHC + - PATH=$HOME/.cabal/bin:$PATH ghc/hadrian/build.sh -j $MODE --no-progress --progress-colour=never --profile=- + +test: + override: + # Test GHC binary + - ghc/inplace/bin/ghc-stage2 -e 1+2 diff --git a/hadrian/doc/cross-compile.md b/hadrian/doc/cross-compile.md new file mode 100644 index 0000000000..1bff4eceaa --- /dev/null +++ b/hadrian/doc/cross-compile.md @@ -0,0 +1,57 @@ +## 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/Settings.hs`, set `stage1Only` and `crossCompiling` to `True`. +- Build the compiler by e.g. `./build.sh --flavour=quickest --integer-simple --skip-configure -V -j` + +After that, you should have built `inplace/bin/ghc-stage1` cross compiler. We will go to the next section to validate this. + +## 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..c7190455a4 --- /dev/null +++ b/hadrian/doc/user-settings.md @@ -0,0 +1,212 @@ +# 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 directory + +Hadrian puts build results into `_build` directory by default, which is +specified by `userBuildRoot`: +```haskell +-- | All build results are put into the 'buildRoot' directory. +userBuildRoot :: BuildRoot +userBuildRoot = BuildRoot "_build" +``` + +## 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 :: 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 "//Evac_thr.c" ? pure [ "-DPARALLEL_GC", "-Irts/sm" ] ] +``` +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. + +## 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 `verboseCommands` 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 +verboseCommands :: Predicate +verboseCommands = input "ghc/Main.hs" +``` +Below are a few other examples: +```haskell +-- Print command lines for all Ghc Link invocations: +verboseCommands = builder (Ghc Link) + +-- Print command lines when compiling files in package compiler using Gcc: +verboseCommands = builder (Gcc Compile) &&^ package compiler + +-- Use patterns when matching files: +verboseCommands = output "//rts/sm/*" &&^ way threaded + +-- Print all commands: +verboseCommands = return True +``` + +## Miscellaneous + +By setting `stage1Only = True` you can disable building Stage2 GHC (i.e. the +`ghc-stage2` executable) and Stage2 utilities, such as `haddock`. Note that all +Stage0 and Stage1 libraries (including `compiler`) will still be built. Enabling +this flag during installation leads to installing `ghc-stage1` instead of +`ghc-stage2`, and `ghc-pkg` that was build with the Stage0 compiler. + +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 = BuildProgressColour (Dull, Magenta) + +-- | Set colour for success messages (e.g. a package is built successfully). +successColour :: SuccessColour +successColour = SuccessColour (Dull, Green) +``` diff --git a/hadrian/doc/windows.md b/hadrian/doc/windows.md new file mode 100644 index 0000000000..b374074474 --- /dev/null +++ b/hadrian/doc/windows.md @@ -0,0 +1,69 @@ +# 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
+stack exec hadrian -- --directory ".." -j --flavour=quickest
+
+# 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..566437e561 --- /dev/null +++ b/hadrian/hadrian.cabal @@ -0,0 +1,142 @@ +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 + , Environment + , Expression + , Flavour + , GHC + , Hadrian.Builder + , Hadrian.Builder.Ar + , Hadrian.Builder.Sphinx + , Hadrian.Builder.Tar + , Hadrian.Expression + , Hadrian.Haskell.Cabal + , Hadrian.Haskell.Cabal.Parse + , Hadrian.Oracles.ArgsHash + , Hadrian.Oracles.DirectoryContents + , Hadrian.Oracles.Path + , Hadrian.Oracles.TextFile + , Hadrian.Package + , Hadrian.Target + , Hadrian.Utilities + , Oracles.Flag + , Oracles.Setting + , Oracles.ModuleFiles + , Oracles.PackageData + , Rules + , Rules.Clean + , Rules.Compile + , Rules.Configure + , Rules.PackageData + , Rules.Dependencies + , Rules.Documentation + , Rules.Generate + , Rules.Gmp + , Rules.Install + , Rules.Libffi + , Rules.Library + , Rules.Program + , Rules.Register + , Rules.Selftest + , Rules.SourceDist + , Rules.Test + , Rules.Wrappers + , Settings + , Settings.Builders.Alex + , Settings.Builders.Common + , Settings.Builders.Cc + , Settings.Builders.Configure + , Settings.Builders.DeriveConstants + , Settings.Builders.GenPrimopCode + , Settings.Builders.Ghc + , Settings.Builders.GhcCabal + , Settings.Builders.GhcPkg + , Settings.Builders.Haddock + , Settings.Builders.Happy + , Settings.Builders.Hsc2Hs + , Settings.Builders.HsCpp + , Settings.Builders.Ld + , Settings.Builders.Make + , Settings.Builders.Xelatex + , Settings.Default + , Settings.Flavours.Development + , Settings.Flavours.Performance + , Settings.Flavours.Profiled + , Settings.Flavours.Quick + , Settings.Flavours.QuickCross + , Settings.Flavours.Quickest + , Settings.Packages.Base + , Settings.Packages.Cabal + , Settings.Packages.Compiler + , Settings.Packages.Ghc + , Settings.Packages.GhcCabal + , Settings.Packages.Ghci + , Settings.Packages.GhcPkg + , Settings.Packages.GhcPrim + , Settings.Packages.Haddock + , Settings.Packages.Haskeline + , Settings.Packages.IntegerGmp + , Settings.Packages.Rts + , Settings.Packages.RunGhc + , Settings.Warnings + , Stage + , Target + , UserSettings + , Utilities + , Way + default-language: Haskell2010 + default-extensions: DeriveFunctor + , DeriveGeneric + , FlexibleInstances + , GeneralizedNewtypeDeriving + , LambdaCase + , RecordWildCards + , ScopedTypeVariables + , TupleSections + other-extensions: MultiParamTypeClasses + , TypeFamilies + build-depends: base >= 4.8 && < 5 + , ansi-terminal == 0.6.* + , Cabal == 2.0.0.2 + , containers == 0.5.* + , directory >= 1.2 && < 1.4 + , extra >= 1.4.7 + , mtl == 2.2.* + , QuickCheck >= 2.6 && < 2.10 + , shake == 0.16.* + , transformers >= 0.4 && < 0.6 + , unordered-containers == 0.2.* + 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/src/Base.hs b/hadrian/src/Base.hs new file mode 100644 index 0000000000..38c879234a --- /dev/null +++ b/hadrian/src/Base.hs @@ -0,0 +1,121 @@ +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, + + -- * Paths + hadrianPath, configPath, configFile, sourcePath, configH, shakeFilesDir, + generatedDir, inplaceBinPath, inplaceLibBinPath, inplaceLibPath, + inplaceLibCopyTargets, templateHscPath, stage0PackageDbDir, + inplacePackageDbPath, packageDbPath, packageDbStamp + ) 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" + +-- | 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" + +-- | The directory in 'buildRoot' containing the 'Stage0' package database. +stage0PackageDbDir :: FilePath +stage0PackageDbDir = "stage0/bootstrapping.conf" + +-- | Path to the inplace package database used in 'Stage1' and later. +inplacePackageDbPath :: FilePath +inplacePackageDbPath = "inplace/lib/package.conf.d" + +-- | Path to the package database used in a given 'Stage'. +packageDbPath :: Stage -> Action FilePath +packageDbPath Stage0 = buildRoot <&> (-/- stage0PackageDbDir) +packageDbPath _ = return inplacePackageDbPath + +-- | We use a stamp file to track the existence of a package database. +packageDbStamp :: FilePath +packageDbStamp = ".stamp" + +-- | Directory for binaries that are built "in place". +inplaceBinPath :: FilePath +inplaceBinPath = "inplace/bin" + +-- | Directory for libraries that are built "in place". +inplaceLibPath :: FilePath +inplaceLibPath = "inplace/lib" + +-- | Directory for binary wrappers, and auxiliary binaries such as @touchy@. +inplaceLibBinPath :: FilePath +inplaceLibBinPath = "inplace/lib/bin" + +-- ref: ghc/ghc.mk:142 +-- ref: driver/ghc.mk +-- ref: utils/hsc2hs/ghc.mk:35 +-- | Files that need to be copied over to 'inplaceLibPath'. +inplaceLibCopyTargets :: [FilePath] +inplaceLibCopyTargets = map (inplaceLibPath -/-) + [ "ghc-usage.txt" + , "ghci-usage.txt" + , "llvm-targets" + , "platformConstants" + , "settings" + , "template-hsc.h" ] + +-- | Path to hsc2hs template. +templateHscPath :: FilePath +templateHscPath = "inplace/lib/template-hsc.h" diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs new file mode 100644 index 0000000000..2b99c03992 --- /dev/null +++ b/hadrian/src/Builder.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE InstanceSigs #-} +module Builder ( + -- * Data types + ArMode (..), CcMode (..), GhcMode (..), GhcPkgMode (..), HaddockMode (..), + SphinxMode (..), TarMode (..), Builder (..), + + -- * Builder properties + builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder, + runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath, + builderEnvironment, + + -- * Ad hoc builder invokation + applyPatch, installDirectory, installData, installScript, installProgram, + linkSymbolic + ) 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 qualified System.Directory.Extra as IO + +import Base +import Context +import GHC +import Oracles.Flag +import Oracles.Setting + +-- | 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 + +-- | GhcPkg can initialise a package database and register packages in it. +data GhcPkgMode = Init | Update 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 an external command invoked in a separate process via 'cmd'. +-- @Ghc Stage0@ is the bootstrapping compiler. +-- @Ghc StageN@, N > 0, is the one built in stage (N - 1). +-- @GhcPkg Stage0@ is the bootstrapping @GhcPkg@. +-- @GhcPkg Stage1@ is the one built in Stage0. +data Builder = Alex + | Ar ArMode Stage + | DeriveConstants + | Cc CcMode Stage + | Configure FilePath + | GenApply + | GenPrimopCode + | Ghc GhcMode Stage + | GhcCabal + | GhcPkg GhcPkgMode Stage + | Haddock HaddockMode + | Happy + | Hpc + | HsCpp + | Hsc2Hs + | Ld + | Make FilePath + | Nm + | Objdump + | Patch + | Perl + | Ranlib + | 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 + GhcCabal -> context Stage0 ghcCabal + GhcPkg _ Stage0 -> Nothing + GhcPkg _ _ -> context Stage0 ghcPkg + Haddock _ -> context Stage2 haddock + Hpc -> context Stage1 hpcBin + 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 + + needBuilder :: Builder -> Action () + needBuilder builder = do + path <- H.builderPath builder + case builder of + Configure dir -> need [dir -/- "configure"] + Hsc2Hs -> need [path, templateHscPath] + Make dir -> need [dir -/- "Makefile"] + _ -> when (isJust $ builderProvenance builder) $ need [path] + + 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 + + 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 + + _ -> 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" + 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" + Ranlib -> fromKey "ranlib" + 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 fixAbsolutePathOnWindows =<< lookupInPath path + +-- | 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"] + +-- | Install a directory. +installDirectory :: FilePath -> Action () +installDirectory dir = do + path <- fixAbsolutePathOnWindows =<< setting InstallDir + putBuild $ "| Install directory " ++ dir + quietly $ cmd path dir + +-- | Install data files to a directory and track them. +installData :: [FilePath] -> FilePath -> Action () +installData fs dir = do + path <- fixAbsolutePathOnWindows =<< setting InstallData + need fs + forM_ fs $ \f -> putBuild $ "| Install data " ++ f ++ " to " ++ dir + quietly $ cmd path fs dir + +-- | Install an executable file to a directory and track it. +installProgram :: FilePath -> FilePath -> Action () +installProgram f dir = do + path <- fixAbsolutePathOnWindows =<< setting InstallProgram + need [f] + putBuild $ "| Install program " ++ f ++ " to " ++ dir + quietly $ cmd path f dir + +-- | Install an executable script to a directory and track it. +installScript :: FilePath -> FilePath -> Action () +installScript f dir = do + path <- fixAbsolutePathOnWindows =<< setting InstallScript + need [f] + putBuild $ "| Install script " ++ f ++ " to " ++ dir + quietly $ cmd path f dir + +-- | Create a symbolic link from source file to target file (when symbolic links +-- are supported) and track the source file. +linkSymbolic :: FilePath -> FilePath -> Action () +linkSymbolic source target = do + lns <- setting LnS + unless (null lns) $ do + need [source] -- Guarantee source is built before printing progress info. + let dir = takeDirectory target + liftIO $ IO.createDirectoryIfMissing True dir + putProgressInfo =<< renderAction "Create symbolic link" source target + quietly $ cmd lns source target diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs new file mode 100644 index 0000000000..1ba38c4850 --- /dev/null +++ b/hadrian/src/CommandLine.hs @@ -0,0 +1,137 @@ +module CommandLine ( + optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple, + cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects, + cmdInstallDestDir + ) where + +import Data.Either +import qualified Data.HashMap.Strict as Map +import Data.List.Extra +import Development.Shake hiding (Normal) +import Hadrian.Utilities +import System.Console.GetOpt +import System.Environment + +-- | All arguments that can be passed to Hadrian via the command line. +data CommandLineArgs = CommandLineArgs + { flavour :: Maybe String + , freeze1 :: Bool + , installDestDir :: Maybe String + , integerSimple :: Bool + , progressColour :: UseColour + , progressInfo :: ProgressInfo + , skipConfigure :: Bool + , splitObjects :: Bool } + deriving (Eq, Show) + +-- | Default values for 'CommandLineArgs'. +defaultCommandLineArgs :: CommandLineArgs +defaultCommandLineArgs = CommandLineArgs + { flavour = Nothing + , freeze1 = False + , installDestDir = Nothing + , integerSimple = False + , progressColour = Auto + , progressInfo = Brief + , skipConfigure = False + , splitObjects = False } + +readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs) +readFreeze1 = Right $ \flags -> flags { freeze1 = True } + +readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms } + +readInstallDestDir :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) +readInstallDestDir ms = Right $ \flags -> flags { installDestDir = ms } + +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 } + +readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs) +readSkipConfigure = Right $ \flags -> flags { skipConfigure = True } + +readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs) +readSplitObjects = Right $ \flags -> flags { splitObjects = True } + +-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments. +optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))] +optDescrs = + [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR") + "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)." + , Option [] ["freeze1"] (NoArg readFreeze1) + "Freeze Stage1 GHC." + , Option [] ["install-destdir"] (OptArg readInstallDestDir "DESTDIR") + "Installation destination directory." + , 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 [] ["skip-configure"] (NoArg readSkipConfigure) + "Skip the boot and configure scripts (if you want to run them manually)." + , Option [] ["split-objects"] (NoArg readSplitObjects) + "Generate split objects (requires a full clean rebuild)." ] + +-- | 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 args Map.empty + +cmdLineArgs :: Action CommandLineArgs +cmdLineArgs = userSetting defaultCommandLineArgs + +cmdFlavour :: Action (Maybe String) +cmdFlavour = flavour <$> cmdLineArgs + +lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool +lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs + +cmdInstallDestDir :: Action (Maybe String) +cmdInstallDestDir = installDestDir <$> cmdLineArgs + +cmdIntegerSimple :: Action Bool +cmdIntegerSimple = integerSimple <$> cmdLineArgs + +cmdProgressColour :: Action UseColour +cmdProgressColour = progressColour <$> cmdLineArgs + +cmdProgressInfo :: Action ProgressInfo +cmdProgressInfo = progressInfo <$> cmdLineArgs + +cmdSkipConfigure :: Action Bool +cmdSkipConfigure = skipConfigure <$> 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..ad1a2d7295 --- /dev/null +++ b/hadrian/src/Context.hs @@ -0,0 +1,158 @@ +module Context ( + -- * Context + Context (..), vanillaContext, stageContext, + + -- * Expressions + getStage, getPackage, getWay, getStagedSettingList, getBuildPath, + withHsPackage, + + -- * Paths + contextDir, buildPath, pkgInplaceConfig, pkgDataFile, pkgSetupConfigFile, + pkgHaddockFile, pkgLibraryFile, pkgLibraryFile0, pkgGhciLibraryFile, + pkgConfFile, objectPath + ) where + +import GHC.Generics +import Hadrian.Expression +import Hadrian.Haskell.Cabal + +import Base +import Oracles.Setting + +-- | 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 + +-- | 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 + +-- | Construct an expression that depends on the Cabal file of the current +-- package and is empty in a non-Haskell context. +withHsPackage :: (Monoid a, Semigroup a) => (FilePath -> Expr Context b a) -> Expr Context b a +withHsPackage expr = do + pkg <- getPackage + case pkgCabalFile pkg of + Just file -> expr file + Nothing -> mempty + +-- | The directory in 'buildRoot' containing build artefacts of a given 'Context'. +contextDir :: Context -> FilePath +contextDir Context {..} = stageString stage -/- pkgPath package + +-- | Path to the directory containing build artefacts of a given 'Context'. +buildPath :: Context -> Action FilePath +buildPath context = buildRoot <&> (-/- contextDir context) + +-- | Get the build path of the current 'Context'. +getBuildPath :: Expr Context b FilePath +getBuildPath = expr . buildPath =<< getContext + +pkgId :: Package -> Action FilePath +pkgId package = case pkgCabalFile package of + Just file -> pkgIdentifier file + Nothing -> return (pkgName package) -- Non-Haskell packages, e.g. rts + +pkgFile :: Context -> String -> String -> Action FilePath +pkgFile context@Context {..} prefix suffix = do + path <- buildPath context + pid <- pkgId package + return $ path -/- prefix ++ pid ++ suffix + +-- | Path to inplace package configuration file of a given 'Context'. +pkgInplaceConfig :: Context -> Action FilePath +pkgInplaceConfig context = do + path <- buildPath context + return $ path -/- "inplace-pkg-config" + +-- | Path to the @package-data.mk@ of a given 'Context'. +pkgDataFile :: Context -> Action FilePath +pkgDataFile context = do + path <- buildPath context + return $ path -/- "package-data.mk" + +-- | Path to the @setup-config@ of a given 'Context'. +pkgSetupConfigFile :: Context -> Action FilePath +pkgSetupConfigFile context = do + path <- buildPath 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 auxiliary library file of a given 'Context', e.g.: +-- @_build/stage1/compiler/build/libHSghc-8.1-0.a@. +pkgLibraryFile0 :: Context -> Action FilePath +pkgLibraryFile0 context@Context {..} = do + extension <- libsuf way + pkgFile context "libHS" ("-0" ++ 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 <- pkgId package + let dbDir | stage == Stage0 = root -/- stage0PackageDbDir + | otherwise = inplacePackageDbPath + return $ dbDir -/- 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/Environment.hs b/hadrian/src/Environment.hs new file mode 100644 index 0000000000..de43efa924 --- /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 + -- ghc-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..7e8220e675 --- /dev/null +++ b/hadrian/src/Expression.hs @@ -0,0 +1,123 @@ +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, getPkgData, getPkgDataList, getOutputs, getInputs, + getInput, getOutput, + + -- * Re-exports + module Base, + module Builder, + module Context, + module GHC + ) where + +import qualified Hadrian.Expression as H +import Hadrian.Expression hiding (Expr, Predicate, Args) + +import Base +import Builder +import GHC +import Context hiding (stage, package, way) +import Oracles.PackageData + +-- | @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] + +-- | Get a value from the @package-data.mk@ file of the current context. +getPkgData :: (FilePath -> PackageData) -> Expr String +getPkgData key = expr . pkgData . key =<< getBuildPath + +-- | Get a list of values from the @package-data.mk@ file of the current context. +getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String] +getPkgDataList key = expr . pkgDataList . key =<< getBuildPath + +-- | 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/Flavour.hs b/hadrian/src/Flavour.hs new file mode 100644 index 0000000000..fcbbb70d45 --- /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 :: Bool, + -- | Enable GHCi debugger. + ghciWithDebugger :: Bool, + -- | Build profiled GHC. + ghcProfiled :: Bool, + -- | Build GHC with debug information. + ghcDebugged :: Bool } diff --git a/hadrian/src/GHC.hs b/hadrian/src/GHC.hs new file mode 100644 index 0000000000..baae940959 --- /dev/null +++ b/hadrian/src/GHC.hs @@ -0,0 +1,289 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module GHC ( + -- * GHC packages + array, base, binary, bytestring, cabal, compareSizes, compiler, containers, + deepseq, deriveConstants, directory, filepath, genapply, genprimopcode, ghc, + ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghci, ghcPkg, ghcPrim, ghcTags, + ghcSplit, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, + integerSimple, iservBin, libffi, mtl, parsec, parallel, pretty, primitive, + process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy, + transformers, unlit, unix, win32, xhtml, ghcPackages, isGhcPackage, + defaultPackages, + + -- * Package information + programName, nonCabalContext, nonHsMainPackage, autogenPath, installStage, + + -- * Miscellaneous + programPath, ghcSplitPath, stripCmdPath, buildDll0 + ) where + +import Base +import CommandLine +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. '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, compareSizes, compiler, containers + , deepseq, deriveConstants, directory, filepath, genapply, genprimopcode + , ghc, ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghci, ghcPkg, ghcPrim + , ghcTags, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp + , integerSimple, iservBin, libffi, mtl, parsec, parallel, pretty, primitive + , process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy + , transformers, unlit, unix, win32, xhtml ] + +-- TODO: Optimise by switching to sets of packages. +isGhcPackage :: Package -> Bool +isGhcPackage = (`elem` ghcPackages) + +-- | Package definitions, see 'Package'. +array = hsLib "array" +base = hsLib "base" +binary = hsLib "binary" +bytestring = hsLib "bytestring" +cabal = hsLib "Cabal" `setPath` "libraries/Cabal/Cabal" +compareSizes = hsUtil "compareSizes" `setPath` "utils/compare_sizes" +compiler = hsTop "ghc" `setPath` "compiler" +containers = hsLib "containers" +deepseq = hsLib "deepseq" +deriveConstants = hsUtil "deriveConstants" +directory = hsLib "directory" +filepath = hsLib "filepath" +genapply = hsUtil "genapply" +genprimopcode = hsUtil "genprimopcode" +ghc = hsPrg "ghc-bin" `setPath` "ghc" +ghcBoot = hsLib "ghc-boot" +ghcBootTh = hsLib "ghc-boot-th" +ghcCabal = hsUtil "ghc-cabal" +ghcCompact = hsLib "ghc-compact" +ghci = hsLib "ghci" +ghcPkg = hsUtil "ghc-pkg" +ghcPrim = hsLib "ghc-prim" +ghcTags = hsUtil "ghctags" +ghcSplit = hsUtil "ghc-split" +haddock = hsUtil "haddock" +haskeline = hsLib "haskeline" +hsc2hs = hsUtil "hsc2hs" +hp2ps = cUtil "hp2ps" +hpc = hsLib "hpc" +hpcBin = hsUtil "hpc-bin" `setPath` "utils/hpc" +integerGmp = hsLib "integer-gmp" +integerSimple = hsLib "integer-simple" +iservBin = hsPrg "iserv-bin" `setPath` "iserv" +libffi = cTop "libffi" +mtl = hsLib "mtl" +parsec = hsLib "parsec" +parallel = hsLib "parallel" +pretty = hsLib "pretty" +primitive = hsLib "primitive" +process = hsLib "process" +rts = cTop "rts" +runGhc = hsUtil "runghc" +stm = hsLib "stm" +templateHaskell = hsLib "template-haskell" +terminfo = hsLib "terminfo" +text = hsLib "text" +time = hsLib "time" +touchy = cUtil "touchy" +transformers = hsLib "transformers" +unlit = cUtil "unlit" +unix = hsLib "unix" +win32 = hsLib "Win32" +xhtml = hsLib "xhtml" + +-- | Construct a Haskell library package, e.g. @array@. +hsLib :: PackageName -> Package +hsLib name = hsLibrary name ("libraries" -/- name) + +-- | Construct a top-level Haskell library package, e.g. @compiler@. +hsTop :: PackageName -> Package +hsTop name = hsLibrary name name + +-- | Construct a top-level C library package, e.g. @rts@. +cTop :: PackageName -> Package +cTop name = cLibrary name name + +-- | Construct a top-level Haskell program package, e.g. @ghc@. +hsPrg :: PackageName -> Package +hsPrg name = hsProgram name name + +-- | Construct a Haskell utility package, e.g. @haddock@. +hsUtil :: PackageName -> Package +hsUtil name = hsProgram name ("utils" -/- name) + +-- | Construct a C utility package, e.g. @haddock@. +cUtil :: PackageName -> Package +cUtil name = cProgram 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 } + +-- | 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 [] + +stage0Packages :: Action [Package] +stage0Packages = do + win <- windowsHost + ios <- iosHost + cross <- crossCompiling + return $ [ binary + , cabal + , compareSizes + , compiler + , deriveConstants + , genapply + , genprimopcode + , ghc + , ghcBoot + , ghcBootTh + , ghcCabal + , ghci + , ghcPkg + , ghcTags + , hsc2hs + , hp2ps + , hpc + , mtl + , parsec + , templateHaskell + , text + , transformers + , unlit ] + ++ [ terminfo | not win, not ios, not cross ] + ++ [ touchy | win ] + +stage1Packages :: Action [Package] +stage1Packages = do + win <- windowsHost + intSimple <- cmdIntegerSimple + libraries0 <- filter isLibrary <$> stage0Packages + return $ libraries0 -- Build all Stage0 libraries in Stage1 + ++ [ array + , base + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc + , ghcCabal + , ghcCompact + , ghcPrim + , haskeline + , hpcBin + , hsc2hs + , if intSimple then integerSimple else integerGmp + , pretty + , process + , rts + , runGhc + , stm + , time + , xhtml ] + ++ [ iservBin | not win ] + ++ [ unix | not win ] + ++ [ win32 | win ] + +stage2Packages :: Action [Package] +stage2Packages = return [haddock] + +-- | 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 -> String +programName Context {..} + | package == ghc = "ghc-stage" ++ show (fromEnum stage + 1) + | package == hpcBin = "hpc" + | package == runGhc = "runhaskell" + | package == iservBin = "ghc-iserv" + | otherwise = pkgName package + +-- | The build stage whose results are used when installing a package, or +-- @Nothing@ if the package is not installed, e.g. because it is a user package. +-- The current implementation installs the /latest/ build stage of a package. +installStage :: Package -> Action (Maybe Stage) +installStage pkg + | not (isGhcPackage pkg) = return Nothing -- Only GHC packages are installed + | otherwise = do + stages <- filterM (fmap (pkg `elem`) . defaultPackages) [Stage0 ..] + return $ if null stages then Nothing else Just (maximum stages) + +-- | Is the program corresponding to a given context built 'inplace', i.e. in +-- the @inplace/bin@ directory? For most programs, only their /latest/ build +-- stages are built 'inplace'. The only exception is the GHC itself, which is +-- built 'inplace' in all stages. The function returns @False@ for libraries and +-- all user packages. +isBuiltInplace :: Context -> Action Bool +isBuiltInplace Context {..} + | isLibrary package = return False + | not (isGhcPackage package) = return False + | package == ghc = return True + | otherwise = (Just stage ==) <$> installStage package + +-- | The 'FilePath' to a program executable in a given 'Context'. +programPath :: Context -> Action FilePath +programPath context@Context {..} = do + path <- buildPath context + inplace <- isBuiltInplace context + let contextPath = if inplace then inplacePath else path + return $ contextPath -/- programName context <.> exe + where + inplacePath | package `elem` [touchy, unlit, iservBin] = inplaceLibBinPath + | otherwise = inplaceBinPath + +-- | Some contexts are special: their packages do not have @.cabal@ metadata or +-- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built +-- yet (this is the case with the 'ghcCabal' package in 'Stage0'). +nonCabalContext :: Context -> Bool +nonCabalContext Context {..} = (package `elem` [hp2ps, rts, touchy, unlit]) + || package == ghcCabal && stage == Stage0 + +-- | Some program packages should not be linked with Haskell main function. +nonHsMainPackage :: Package -> Bool +nonHsMainPackage = (`elem` [ghc, hp2ps, iservBin, touchy, unlit]) + +-- | Path to the autogen directory generated by @ghc-cabal@ of a given 'Context'. +autogenPath :: Context -> Action FilePath +autogenPath context@Context {..} + | isLibrary package = autogen "build" + | package == ghc = autogen "build/ghc" + | package == hpcBin = autogen "build/hpc" + | package == iservBin = autogen "build/iserv" + | otherwise = autogen $ "build" -/- pkgName package + where + autogen dir = buildPath context <&> (-/- dir -/- "autogen") + +-- | @ghc-split@ is a Perl script used by GHC with @-split-objs@ flag. It is +-- generated in "Rules.Generators.GhcSplit". +ghcSplitPath :: FilePath +ghcSplitPath = inplaceLibBinPath -/- "ghc-split" + +-- ref: mk/config.mk +-- | Command line tool for stripping. +stripCmdPath :: Action FilePath +stripCmdPath = do + targetPlatform <- setting TargetPlatform + top <- topDirectory + case targetPlatform of + "x86_64-unknown-mingw32" -> + return (top -/- "inplace/mingw/bin/strip.exe") + "arm-unknown-linux" -> + return ":" -- HACK: from the make-based system, see the ref above + _ -> return "strip" + +buildDll0 :: Context -> Action Bool +buildDll0 Context {..} = do + windows <- windowsHost + return $ windows && stage == Stage1 && package == compiler diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs new file mode 100644 index 0000000000..4de658edc3 --- /dev/null +++ b/hadrian/src/Hadrian/Builder.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- | +-- 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 (..), runBuilder, runBuilderWithCmdOptions, + build, buildWithResources, buildWithCmdOptions, getBuilderPath, + builderEnvironment + ) 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 + + -- | Make sure a builder exists and rebuild it if out of date. + needBuilder :: b -> Action () + needBuilder builder = do + path <- builderPath builder + need [path] + + -- | 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 + +-- | 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 [] + +-- | 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 [] + +buildWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action () +buildWith rs opts target args = do + needBuilder (builder target) + argList <- interpret target args + trackArgsHash target -- Rerun the rule if the hash of argList has changed. + putInfo target + verbose <- interpret target verboseCommand + let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly + quietlyUnlessVerbose $ runBuilderWith (builder target) $ + BuildInfo { buildArgs = argList + , buildInputs = inputs target + , buildOutputs = outputs target + , buildOptions = opts + , buildResources = rs } + +-- | Print out information about the command being executed. +putInfo :: Show b => Target c b -> Action () +putInfo 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)" + +-- | 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..d51e3c7bee --- /dev/null +++ b/hadrian/src/Hadrian/Builder/Tar.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- 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..e5c01f8935 --- /dev/null +++ b/hadrian/src/Hadrian/Expression.hs @@ -0,0 +1,153 @@ +{-# 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 Data.Semigroup +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, Semigroup 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..ab5f334f9b --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Cabal.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Haskell.Cabal +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- 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, pkgDependencies, pkgSynopsis + ) where + +import Development.Shake + +import Hadrian.Haskell.Cabal.Parse +import Hadrian.Package +import Hadrian.Oracles.TextFile + +-- | Read a Cabal file and return the package version. The Cabal file is tracked. +pkgVersion :: FilePath -> Action String +pkgVersion cabalFile = version <$> readCabalFile cabalFile + +-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@. +-- The Cabal file is tracked. +pkgIdentifier :: FilePath -> Action String +pkgIdentifier cabalFile = do + cabal <- readCabalFile cabalFile + return $ if null (version cabal) + then name cabal + else name cabal ++ "-" ++ version cabal + +-- | 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 :: FilePath -> Action [PackageName] +pkgDependencies cabalFile = dependencies <$> readCabalFile cabalFile + +-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked. +pkgSynopsis :: FilePath -> Action String +pkgSynopsis cabalFile = synopsis <$> readCabalFile cabalFile diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs new file mode 100644 index 0000000000..578eeacc52 --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs @@ -0,0 +1,63 @@ +----------------------------------------------------------------------------- +-- | +-- 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 (Cabal (..), parseCabal) where + +import Data.List.Extra +import Development.Shake +import Development.Shake.Classes +import qualified Distribution.Package as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Parse as C +import qualified Distribution.Text as C +import qualified Distribution.Types.CondTree as C +import qualified Distribution.Verbosity as C + +import Hadrian.Package + +-- TODO: Use fine-grain tracking instead of tracking the whole Cabal file. +-- | Haskell package metadata extracted from a Cabal file. +data Cabal = Cabal + { dependencies :: [PackageName] + , name :: PackageName + , synopsis :: String + , version :: String + } deriving (Eq, Read, Show, Typeable) + +instance Binary Cabal where + put = put . show + get = fmap read get + +instance Hashable Cabal where + hashWithSalt salt = hashWithSalt salt . show + +instance NFData Cabal where + rnf (Cabal a b c d) = a `seq` b `seq` c `seq` d `seq` () + +-- | Parse a Cabal file. +parseCabal :: FilePath -> IO Cabal +parseCabal file = do + gpd <- liftIO $ C.readGenericPackageDescription C.silent file + 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] + return $ Cabal deps name (C.synopsis pd) version + +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 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/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..ceccc23db2 --- /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 $ addOracle $ \(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 $ addOracle $ \(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..6d4f048c7d --- /dev/null +++ b/hadrian/src/Hadrian/Oracles/TextFile.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hadrian.Oracles.TextFile +-- Copyright : (c) Andrey Mokhov 2014-2017 +-- 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 ( + readTextFile, lookupValue, lookupValueOrEmpty, lookupValueOrError, + lookupValues, lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, + readCabalFile, 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.Haskell.Cabal.Parse +import Hadrian.Utilities + +newtype TextFile = TextFile FilePath + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult TextFile = String + +newtype CabalFile = CabalFile FilePath + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult CabalFile = Cabal + +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] + +-- | Read a text file, caching and tracking the result. To read and track +-- individual lines of a text file use 'lookupValue' and its derivatives. +readTextFile :: FilePath -> Action String +readTextFile = askOracle . TextFile + +-- | 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) + +-- | Read and parse a @.cabal@ file, caching and tracking the result. +readCabalFile :: FilePath -> Action Cabal +readCabalFile = askOracle . CabalFile + +-- | This oracle reads and parses text files to answer 'readTextFile' and +-- 'lookupValue' queries, as well as their derivatives, tracking the results. +textFileOracle :: Rules () +textFileOracle = do + text <- newCache $ \file -> do + need [file] + putLoud $ "| TextFile oracle: reading " ++ quote file ++ "..." + liftIO $ readFile file + void $ addOracle $ \(TextFile file) -> text file + + kv <- newCache $ \file -> do + need [file] + putLoud $ "| KeyValue oracle: reading " ++ quote file ++ "..." + liftIO $ readConfigFile file + void $ addOracle $ \(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 $ addOracle $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file + + cabal <- newCache $ \file -> do + need [file] + putLoud $ "| CabalFile oracle: reading " ++ quote file ++ "..." + liftIO $ parseCabal file + void $ addOracle $ \(CabalFile file) -> cabal file diff --git a/hadrian/src/Hadrian/Package.hs b/hadrian/src/Hadrian/Package.hs new file mode 100644 index 0000000000..11a6998f65 --- /dev/null +++ b/hadrian/src/Hadrian/Package.hs @@ -0,0 +1,120 @@ +----------------------------------------------------------------------------- +-- | +-- 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, PackageLanguage, PackageType, + + -- * Construction and properties + cLibrary, cProgram, hsLibrary, hsProgram, + isLibrary, isProgram, isCPackage, isHsPackage, + + -- * Package directory structure + pkgCabalFile, unsafePkgCabalFile + ) where + +import Data.Maybe +import Development.Shake.Classes +import Development.Shake.FilePath +import GHC.Generics +import GHC.Stack +import Hadrian.Utilities + +data PackageLanguage = C | Haskell deriving (Generic, Show) + +-- TODO: Make PackageType more precise. +-- See https://github.com/snowleopard/hadrian/issues/12. +data PackageType = Library | Program deriving (Generic, Show) + +type PackageName = String + +-- TODO: Consider turning Package into a GADT indexed with language and type. +data Package = Package { + -- | The package language. 'C' and 'Haskell' packages are supported. + pkgLanguage :: PackageLanguage, + -- | 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 (Generic, Show) + +instance Eq Package where + p == q = pkgName p == pkgName q + +instance Ord Package where + compare p q = compare (pkgName p) (pkgName q) + +instance Binary PackageLanguage +instance Hashable PackageLanguage +instance NFData PackageLanguage + +instance Binary PackageType +instance Hashable PackageType +instance NFData PackageType + +instance Binary Package +instance Hashable Package +instance NFData Package + +-- | Construct a C library package. +cLibrary :: PackageName -> FilePath -> Package +cLibrary = Package C Library + +-- | Construct a C program package. +cProgram :: PackageName -> FilePath -> Package +cProgram = Package C Program + +-- | Construct a Haskell library package. +hsLibrary :: PackageName -> FilePath -> Package +hsLibrary = Package Haskell Library + +-- | Construct a Haskell program package. +hsProgram :: PackageName -> FilePath -> Package +hsProgram = Package Haskell Program + +-- | 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 + +-- | Is this a C package? +isCPackage :: Package -> Bool +isCPackage (Package C _ _ _) = True +isCPackage _ = False + +-- | Is this a Haskell package? +isHsPackage :: Package -> Bool +isHsPackage (Package Haskell _ _ _) = True +isHsPackage _ = False + +-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@, +-- or @Nothing@ if the argument is not a Haskell package. +pkgCabalFile :: Package -> Maybe FilePath +pkgCabalFile p | isHsPackage p = Just $ pkgPath p -/- pkgName p <.> "cabal" + | otherwise = Nothing + +-- | Like 'pkgCabalFile' but raises an error on a non-Haskell package. +unsafePkgCabalFile :: HasCallStack => Package -> FilePath +unsafePkgCabalFile p = fromMaybe (error msg) (pkgCabalFile p) + where + msg = "[unsafePkgCabalFile] Not a Haskell package: " ++ show p 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..1cd22b1179 --- /dev/null +++ b/hadrian/src/Hadrian/Utilities.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE TypeFamilies #-} +module Hadrian.Utilities ( + -- * List manipulation + fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize, + + -- * String manipulation + quote, yesNo, + + -- * FilePath manipulation + unifyPath, (-/-), + + -- * Accessing Shake's type-indexed map + insertExtra, lookupExtra, userSetting, + + -- * Paths + BuildRoot (..), buildRoot, isGeneratedSource, + + -- * File system operations + copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile, + createDirectory, copyDirectory, moveDirectory, removeDirectory, + + -- * Diagnostic info + UseColour (..), putColoured, BuildProgressColour (..), putBuild, + SuccessColour (..), putSuccess, ProgressInfo (..), + putProgressInfo, renderAction, 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.Console.ANSI +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" + +-- | 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 + +newtype BuildRoot = BuildRoot FilePath deriving Typeable + +-- | All build results are put into the 'buildRoot' directory. +buildRoot :: Action FilePath +buildRoot = do + BuildRoot path <- userSetting (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) + +-- | A more colourful version of Shake's 'putNormal'. +putColoured :: ColorIntensity -> Color -> String -> Action () +putColoured intensity colour msg = do + useColour <- userSetting Never + supported <- liftIO $ hSupportsANSI IO.stdout + let c Never = False + c Auto = supported || IO.isWindows -- Colours do work on Windows + c Always = True + when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour] + putNormal msg + when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout + +newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color) + deriving Typeable + +-- | Default 'BuildProgressColour'. +magenta :: BuildProgressColour +magenta = BuildProgressColour (Dull, Magenta) + +-- | Print a build progress message (e.g. executing a build command). +putBuild :: String -> Action () +putBuild msg = do + BuildProgressColour (intensity, colour) <- userSetting magenta + putColoured intensity colour msg + +newtype SuccessColour = SuccessColour (ColorIntensity, Color) + deriving Typeable + +-- | Default 'SuccessColour'. +green :: SuccessColour +green = SuccessColour (Dull, Green) + +-- | Print a success message (e.g. a package is built successfully). +putSuccess :: String -> Action () +putSuccess msg = do + SuccessColour (intensity, colour) <- userSetting green + putColoured intensity colour 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 the successful build of a program. +renderProgram :: String -> String -> Maybe String -> String +renderProgram name bin synopsis = renderBox $ + [ "Successfully built program " ++ name + , "Executable: " ++ bin ] ++ + [ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ] + +-- | Render the successful build of a library. +renderLibrary :: String -> String -> Maybe String -> String +renderLibrary name lib synopsis = renderBox $ + [ "Successfully built library " ++ name + , "Library: " ++ lib ] ++ + [ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ] + +prettySynopsis :: Maybe String -> String +prettySynopsis Nothing = "" +prettySynopsis (Just 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..52af0adf7c --- /dev/null +++ b/hadrian/src/Main.hs @@ -0,0 +1,59 @@ +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.Install +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 UserSettings.userBuildRoot + $ insertExtra (VerboseCommand UserSettings.verboseCommand) argsMap + + BuildRoot buildRoot = UserSettings.userBuildRoot + + 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.Install.installRules + 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..447f0bc076 --- /dev/null +++ b/hadrian/src/Oracles/Flag.hs @@ -0,0 +1,80 @@ +module Oracles.Flag ( + Flag (..), flag, crossCompiling, platformSupportsSharedLibs, + ghcWithSMP, ghcWithNativeCodeGen, supportsSplitObjects + ) where + +import Hadrian.Oracles.TextFile + +import Base +import Oracles.Setting + +data Flag = ArSupportsAtFile + | CrossCompiling + | GccIsClang + | GccLt34 + | GccLt44 + | GccLt46 + | 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" + GccLt34 -> "gcc-lt-34" + GccLt44 -> "gcc-lt-44" + GccLt46 -> "gcc-lt-46" + 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" + +crossCompiling :: Action Bool +crossCompiling = flag CrossCompiling + +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..c7175dbc1c --- /dev/null +++ b/hadrian/src/Oracles/ModuleFiles.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TypeFamilies #-} +module Oracles.ModuleFiles ( + decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle + ) where + +import qualified Data.HashMap.Strict as Map + +import Base +import Builder +import Context +import GHC +import Oracles.PackageData + +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 :: [(String, Builder)] +otherExtensions = [ (".x" , Alex ) + , (".y" , Happy ) + , (".ly" , Happy ) + , (".hsc", Hsc2Hs) ] + +-- | We match the following file patterns when looking for module files. +moduleFilePatterns :: [FilePattern] +moduleFilePatterns = map ("*" ++) $ haskellExtensions ++ map fst otherExtensions + +-- | Given a FilePath determine the corresponding builder. +determineBuilder :: FilePath -> Maybe Builder +determineBuilder file = lookup (takeExtension file) otherExtensions + +-- | Given a module name extract the directory and file name, e.g.: +-- +-- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity") +-- > decodeModule "Prelude" == ("", "Prelude") +decodeModule :: String -> (FilePath, String) +decodeModule modName = (intercalate "/" (init xs), last xs) + where + xs = words $ replaceEq '.' ' ' modName + +-- | 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 -> String +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 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 + path <- buildPath context + modules <- pkgDataList (Modules path) + -- GHC.Prim module is only for documentation, we do not actually build it. + mapM (objectPath context . moduleSource) (filter (/= "GHC.Prim") modules) + +-- | Generated module files live in the 'Context' specific build directory. +generatedFile :: Context -> String -> Action FilePath +generatedFile context moduleName = do + path <- buildPath context + return $ path -/- moduleSource moduleName + +moduleSource :: String -> FilePath +moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs" + +-- | Module files for a given 'Context'. +contextFiles :: Context -> Action [(String, Maybe FilePath)] +contextFiles context@Context {..} = do + path <- buildPath context + modules <- fmap sort . pkgDataList $ Modules path + 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 . addOracle $ \(ModuleFiles (stage, package)) -> do + let context = vanillaContext stage package + path <- buildPath context + srcDirs <- pkgDataList $ SrcDirs path + modules <- fmap sort . pkgDataList $ Modules path + autogen <- autogenPath context + let dirs = autogen : map (pkgPath package -/-) srcDirs + modDirFiles = groupSort $ map decodeModule 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 + let cmp f = compare (dropExtension f) + found = intersectOrd cmp files mFiles + return (map (fullDir -/-) found, mDir) + let pairs = sort [ (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 + + addOracle $ \(Generator (stage, package, file)) -> + Map.lookup file <$> generators (stage, package) diff --git a/hadrian/src/Oracles/PackageData.hs b/hadrian/src/Oracles/PackageData.hs new file mode 100644 index 0000000000..cdfe9bfb48 --- /dev/null +++ b/hadrian/src/Oracles/PackageData.hs @@ -0,0 +1,66 @@ +module Oracles.PackageData ( + PackageData (..), PackageDataList (..), pkgData, pkgDataList + ) where + +import Hadrian.Oracles.TextFile + +import Base + +newtype PackageData = BuildGhciLib FilePath + +data PackageDataList = AsmSrcs FilePath + | CcArgs FilePath + | CSrcs FilePath + | CmmSrcs FilePath + | CppArgs FilePath + | DepCcArgs FilePath + | DepExtraLibs FilePath + | DepIds FilePath + | DepIncludeDirs FilePath + | DepLdArgs FilePath + | DepLibDirs FilePath + | DepNames FilePath + | Deps FilePath + | HiddenModules FilePath + | HsArgs FilePath + | IncludeDirs FilePath + | LdArgs FilePath + | Modules FilePath + | SrcDirs FilePath + +askPackageData :: FilePath -> String -> Action String +askPackageData path = lookupValueOrEmpty (path -/- "package-data.mk") + +-- | For each @PackageData path@ the file 'path/package-data.mk' contains a line +-- of the form 'path_VERSION = 1.2.3.4'. @pkgData (PackageData path)@ is an +-- Action that consults the file and returns "1.2.3.4". +pkgData :: PackageData -> Action String +pkgData packageData = case packageData of + BuildGhciLib path -> askPackageData path "BUILD_GHCI_LIB" + +-- | @PackageDataList path@ is used for multiple string options separated by +-- spaces, such as @path_MODULES = Data.Array Data.Array.Base ...@. +-- @pkgListData Modules@ therefore returns ["Data.Array", "Data.Array.Base", ...] +pkgDataList :: PackageDataList -> Action [String] +pkgDataList packageData = fmap (map unquote . words) $ case packageData of + AsmSrcs path -> askPackageData path "S_SRCS" + CcArgs path -> askPackageData path "CC_OPTS" + CSrcs path -> askPackageData path "C_SRCS" + CmmSrcs path -> askPackageData path "CMM_SRCS" + CppArgs path -> askPackageData path "CPP_OPTS" + DepCcArgs path -> askPackageData path "DEP_CC_OPTS" + DepExtraLibs path -> askPackageData path "DEP_EXTRA_LIBS" + DepIds path -> askPackageData path "DEP_IPIDS" + DepIncludeDirs path -> askPackageData path "DEP_INCLUDE_DIRS_SINGLE_QUOTED" + DepLibDirs path -> askPackageData path "DEP_LIB_DIRS_SINGLE_QUOTED" + DepLdArgs path -> askPackageData path "DEP_LD_OPTS" + DepNames path -> askPackageData path "DEP_NAMES" + Deps path -> askPackageData path "DEPS" + HiddenModules path -> askPackageData path "HIDDEN_MODULES" + HsArgs path -> askPackageData path "HC_OPTS" + IncludeDirs path -> askPackageData path "INCLUDE_DIRS" + LdArgs path -> askPackageData path "LD_OPTS" + Modules path -> askPackageData path "MODULES" + SrcDirs path -> askPackageData path "HS_SRC_DIRS" + where + unquote = dropWhile (== '\'') . dropWhileEnd (== '\'') diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs new file mode 100644 index 0000000000..aa49011e1e --- /dev/null +++ b/hadrian/src/Oracles/Setting.hs @@ -0,0 +1,236 @@ +module Oracles.Setting ( + configFile, Setting (..), SettingList (..), setting, settingList, getSetting, + getSettingList, anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs, + ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors, + ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost, + topDirectory, relocatableBuild, installDocDir, installGhcLibDir, libsuf + ) where + +import Hadrian.Expression +import Hadrian.Oracles.TextFile +import Hadrian.Oracles.Path + +import Base + +-- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). +-- | Each 'Setting' comes from @system.config@ file, e.g. 'target-os = mingw32'. +-- @setting TargetOs@ looks up the config file and returns "mingw32". +-- 'SettingList' is used for multiple string values separated by spaces, such +-- as @gmp-include-dirs = a b@. +-- @settingList GmpIncludeDirs@ therefore returns a list of strings ["a", "b"]. +data Setting = BuildArch + | BuildOs + | BuildPlatform + | BuildVendor + | CcClangBackend + | CcLlvmBackend + | DynamicExtension + | GhcMajorVersion + | GhcMinorVersion + | GhcPatchLevel + | GhcVersion + | GhcSourcePath + | HostArch + | HostOs + | HostPlatform + | HostVendor + | ProjectGitCommitId + | ProjectName + | ProjectVersion + | ProjectVersionInt + | ProjectPatchLevel + | ProjectPatchLevel1 + | ProjectPatchLevel2 + | TargetArch + | TargetOs + | TargetPlatform + | TargetPlatformFull + | TargetVendor + | LlvmTarget + | FfiIncludeDir + | FfiLibDir + | GmpIncludeDir + | GmpLibDir + | IconvIncludeDir + | IconvLibDir + | CursesLibDir + -- Paths to where GHC is installed (ref: mk/install.mk) + | InstallPrefix + | InstallBinDir + | InstallLibDir + | InstallDataRootDir + -- Command lines for invoking the @install@ utility + | Install + | InstallData + | InstallProgram + | InstallScript + | InstallDir + -- Command line for creating a symbolic link + | LnS + +data SettingList = ConfCcArgs Stage + | ConfCppArgs Stage + | ConfGccLinkerArgs Stage + | ConfLdLinkerArgs Stage + | HsCppArgs + +-- | Maps 'Setting's to names in @cfg/system.config.in@. +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" + DynamicExtension -> "dynamic-extension" + GhcMajorVersion -> "ghc-major-version" + GhcMinorVersion -> "ghc-minor-version" + GhcPatchLevel -> "ghc-patch-level" + GhcVersion -> "ghc-version" + GhcSourcePath -> "ghc-source-path" + HostArch -> "host-arch" + HostOs -> "host-os" + HostPlatform -> "host-platform" + HostVendor -> "host-vendor" + 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" + TargetArch -> "target-arch" + TargetOs -> "target-os" + TargetPlatform -> "target-platform" + TargetPlatformFull -> "target-platform-full" + TargetVendor -> "target-vendor" + LlvmTarget -> "llvm-target" + FfiIncludeDir -> "ffi-include-dir" + FfiLibDir -> "ffi-lib-dir" + GmpIncludeDir -> "gmp-include-dir" + GmpLibDir -> "gmp-lib-dir" + IconvIncludeDir -> "iconv-include-dir" + IconvLibDir -> "iconv-lib-dir" + CursesLibDir -> "curses-lib-dir" + InstallPrefix -> "install-prefix" + InstallBinDir -> "install-bindir" + InstallLibDir -> "install-libdir" + InstallDataRootDir -> "install-datarootdir" + Install -> "install" + InstallDir -> "install-dir" + InstallProgram -> "install-program" + InstallScript -> "install-script" + InstallData -> "install-data" + LnS -> "ln-s" + +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" + +-- | Get a configuration setting. +getSetting :: Setting -> Expr c b String +getSetting = expr . setting + +-- | Get a list of configuration settings. +getSettingList :: SettingList -> Args c b +getSettingList = expr . settingList + +matchSetting :: Setting -> [String] -> Action Bool +matchSetting key values = (`elem` values) <$> setting key + +anyTargetPlatform :: [String] -> Action Bool +anyTargetPlatform = matchSetting TargetPlatformFull + +anyTargetOs :: [String] -> Action Bool +anyTargetOs = matchSetting TargetOs + +anyTargetArch :: [String] -> Action Bool +anyTargetArch = matchSetting TargetArch + +anyHostOs :: [String] -> Action Bool +anyHostOs = matchSetting HostOs + +iosHost :: Action Bool +iosHost = anyHostOs ["ios"] + +osxHost :: Action Bool +osxHost = anyHostOs ["darwin"] + +windowsHost :: Action Bool +windowsHost = anyHostOs ["mingw32", "cygwin32"] + +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 + +ghcEnableTablesNextToCode :: Action Bool +ghcEnableTablesNextToCode = notM $ anyTargetArch ["ia64", "powerpc64", "powerpc64le"] + +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 + +-- ref: https://ghc.haskell.org/trac/ghc/wiki/Building/Installing#HowGHCfindsitsfiles +-- | On Windows we normally build a relocatable installation, which assumes that +-- the library directory @libdir@ is in a fixed location relative to the GHC +-- binary, namely @../lib@. +relocatableBuild :: Action Bool +relocatableBuild = windowsHost + +installDocDir :: Action String +installDocDir = do + version <- setting ProjectVersion + dataDir <- setting InstallDataRootDir + return $ dataDir -/- ("doc/ghc-" ++ version) + +-- | Path to the GHC source tree. +topDirectory :: Action FilePath +topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath + +-- ref: mk/install.mk:101 +-- TODO: CroosCompilePrefix +-- | Unix: override @libdir@ and @datadir@ to put GHC-specific files in a +-- subdirectory with the version number included. +installGhcLibDir :: Action String +installGhcLibDir = do + rBuild <- relocatableBuild + libdir <- setting InstallLibDir + if rBuild then return libdir + else do + version <- setting ProjectVersion + return $ libdir -/- ("ghc-" ++ version) + +-- TODO: find out why we need version number in the dynamic suffix +-- The current theory: dynamic libraries are eventually 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 = + if not (wayUnit Dynamic way) + then return $ waySuffix way ++ ".a" -- e.g., _p.a + else do + extension <- setting DynamicExtension -- e.g., .dll or .so + version <- setting ProjectVersion -- e.g., 7.11.20141222 + let prefix = wayPrefix $ removeWayUnit Dynamic way + -- e.g., p_ghc7.11.20141222.dll (the result) + return $ prefix ++ "-ghc" ++ version ++ extension diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs new file mode 100644 index 0000000000..d5c26e8e94 --- /dev/null +++ b/hadrian/src/Rules.hs @@ -0,0 +1,123 @@ +module Rules (buildRules, oracleRules, packageTargets, topLevelTargets) where + +import qualified Hadrian.Oracles.ArgsHash +import qualified Hadrian.Oracles.DirectoryContents +import qualified Hadrian.Oracles.Path +import qualified Hadrian.Oracles.TextFile + +import Expression +import qualified Oracles.ModuleFiles +import qualified Rules.Compile +import qualified Rules.PackageData +import qualified Rules.Dependencies +import qualified Rules.Documentation +import qualified Rules.Generate +import qualified Rules.Configure +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 ..] + +-- | This rule calls 'need' on all top-level build targets, respecting the +-- 'Stage1Only' flag. +topLevelTargets :: Rules () +topLevelTargets = action $ do + let libraryPackages = filter isLibrary (knownPackages \\ [libffi]) + need =<< if stage1Only + then do + libs <- concatForM [Stage0, Stage1] $ \stage -> + concatForM libraryPackages $ packageTargets False stage + prgs <- concatForM programsStage1Only $ packageTargets False Stage0 + return $ libs ++ prgs ++ inplaceLibCopyTargets + else do + targets <- concatForM allStages $ \stage -> + concatForM (knownPackages \\ [libffi]) $ + packageTargets False stage + return $ targets ++ inplaceLibCopyTargets + +-- 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 running @ghc-cabal@ to determine wether +-- GHCi library needs to be built for this package. 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 we need to run @ghc-cabal@ in the order respecting package 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 | not (nonCabalContext context) ] ++ 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 + + forM_ contexts $ mconcat + [ Rules.Compile.compilePackage readPackageDb + , Rules.Library.buildPackageLibrary ] + + let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic] + forM_ dynamicContexts Rules.Library.buildDynamicLib + + forM_ (filter isProgram knownPackages) $ + Rules.Program.buildProgram readPackageDb + + forM_ vanillaContexts $ mconcat + [ Rules.PackageData.buildPackageData + , Rules.Dependencies.buildPackageDependencies readPackageDb + , Rules.Documentation.buildPackageDocumentation + , Rules.Library.buildPackageGhciLibrary + , Rules.Generate.generatePackageCode + , Rules.Register.registerPackage writePackageDb ] + +buildRules :: Rules () +buildRules = do + Rules.Configure.configureRules + Rules.Generate.copyRules + Rules.Generate.generateRules + Rules.Gmp.gmpRules + Rules.Libffi.libffiRules + packageRules + +oracleRules :: Rules () +oracleRules = do + Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs + Hadrian.Oracles.DirectoryContents.directoryContentsOracle + Hadrian.Oracles.Path.pathOracle + Hadrian.Oracles.TextFile.textFileOracle + Oracles.ModuleFiles.moduleFilesOracle + +programsStage1Only :: [Package] +programsStage1Only = [ deriveConstants, genapply, genprimopcode, ghc, ghcCabal + , ghcPkg, hp2ps, hpc, hsc2hs, runGhc ] diff --git a/hadrian/src/Rules/Clean.hs b/hadrian/src/Rules/Clean.hs new file mode 100644 index 0000000000..d11cbf5e53 --- /dev/null +++ b/hadrian/src/Rules/Clean.hs @@ -0,0 +1,23 @@ +module Rules.Clean (clean, cleanSourceTree, cleanRules) where + +import Base + +clean :: Action () +clean = do + cleanSourceTree + putBuild "| Remove Hadrian files..." + path <- buildRoot + removeDirectory $ path -/- generatedDir + removeFilesAfter path ["//*"] + putSuccess "| Done. " + +cleanSourceTree :: Action () +cleanSourceTree = do + path <- buildRoot + forM_ [Stage0 ..] $ removeDirectory . (path -/-) . stageString + removeDirectory inplaceBinPath + removeDirectory inplaceLibPath + removeDirectory "sdistprep" + +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..a4b1278660 --- /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 + let dir = "//" ++ contextDir 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 <- buildPath context + (src, deps) <- lookupDependencies (path -/- ".dependencies") obj + need $ src : deps + when (isLibrary package) $ need =<< return <$> pkgConfFile context + needLibrary =<< contextDependencies context + buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj] + + priority 2.0 $ do + nonHs "c" %> compile (Ghc CompileCWithGhc) (obj2src "c" isGeneratedCFile ) + 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..dd016c149f --- /dev/null +++ b/hadrian/src/Rules/Configure.hs @@ -0,0 +1,42 @@ +module Rules.Configure (configureRules) where + +import qualified System.Info.Extra as System + +import Base +import Builder +import CommandLine +import Context +import GHC +import Target +import Utilities + +configureRules :: Rules () +configureRules = do + [configFile, "settings", configH] &%> \outs -> do + skip <- cmdSkipConfigure + if skip + then unlessM (doesFileExist configFile) $ + error $ "Configuration file " ++ configFile ++ " is missing." + ++ "\nRun the configure script manually or do not use the " + ++ "--skip-configure flag." + 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 + + ["configure", configH <.> "in"] &%> \_ -> do + skip <- cmdSkipConfigure + if skip + then unlessM (doesFileExist "configure") $ + error $ "The configure script is missing.\nRun the boot script" + ++ " manually or do not use the --skip-configure flag." + else do + need ["configure.ac"] + putBuild "| Running boot..." + verbosity <- getVerbosity + quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot" diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs new file mode 100644 index 0000000000..f27ef0d912 --- /dev/null +++ b/hadrian/src/Rules/Dependencies.hs @@ -0,0 +1,33 @@ +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 {..} = + "//" ++ contextDir context -/- ".dependencies" %> \deps -> do + srcs <- hsSources context + need srcs + orderOnly =<< interpretInContext context generatedDependencies + let mk = deps <.> "mk" + if null srcs + then writeFileChanged mk "" + else buildWithResources rs $ + target context (Ghc FindHsDependencies stage) srcs [mk] + removeFile $ mk <.> "bak" + mkDeps <- readFile' 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..5a5698c995 --- /dev/null +++ b/hadrian/src/Rules/Documentation.hs @@ -0,0 +1,197 @@ +module Rules.Documentation ( + -- * Rules + buildPackageDocumentation, documentationRules, + + -- * Utilities + haddockDependencies + ) where + +import Base +import Context +import Flavour +import GHC +import Oracles.ModuleFiles +import Oracles.PackageData +import Settings +import Target +import Utilities + +-- | Build all documentation +documentationRules :: Rules () +documentationRules = do + buildHtmlDocumentation + buildPdfDocumentation + buildDocumentationArchives + buildManPage + "//docs//gen_contents_index" %> copyFile "libraries/gen_contents_index" + "//docs//prologue.txt" %> copyFile "libraries/prologue.txt" + "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" ] + need [ root -/- htmlRoot -/- "libraries" -/- "prologue.txt" ] + need [manPagePath] + +manPagePath :: FilePath +manPagePath = "_build/docs/users_guide/build-man/ghc.1" + +-- TODO: Add support for Documentation Packages so we can +-- run the builders without this hack. +docPackage :: Package +docPackage = hsLibrary "Documentation" "docs" + +docPaths :: [FilePath] +docPaths = [ "libraries", "users_guide", "Haddock" ] + +docRoot :: FilePath +docRoot = "docs" + +htmlRoot :: FilePath +htmlRoot = docRoot -/- "html" + +pdfRoot :: FilePath +pdfRoot = docRoot -/- "pdfs" + +archiveRoot :: FilePath +archiveRoot = docRoot -/- "archives" + +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: Replace this with pkgPath when support is added +-- for Documentation Packages. +pathPath :: FilePath -> FilePath +pathPath "users_guide" = "docs/users_guide" +pathPath "Haddock" = "utils/haddock/doc" +pathPath _ = "" + +---------------------------------------------------------------------- +-- HTML + +-- | Build all HTML documentation +buildHtmlDocumentation :: Rules () +buildHtmlDocumentation = do + mapM_ buildSphinxHtml $ docPaths \\ [ "libraries" ] + buildLibraryDocumentation + "//" ++ htmlRoot -/- "index.html" %> \file -> do + root <- buildRoot + need $ map ((root -/-) . pathIndex) docPaths + copyFileUntracked "docs/index.html" file + +----------------------------- +-- Sphinx + +-- | Compile a Sphinx ReStructured Text package to HTML +buildSphinxHtml :: FilePath -> Rules () +buildSphinxHtml path = do + "//" ++ htmlRoot -/- path -/- "index.html" %> \file -> do + let dest = takeDirectory file + context = vanillaContext Stage0 docPackage + build $ target context (Sphinx Html) [pathPath path] [dest] + +----------------------------- +-- Haddock + +-- | Build the haddocks for GHC's libraries +buildLibraryDocumentation :: Rules () +buildLibraryDocumentation = do + "//" ++ htmlRoot -/- "libraries/index.html" %> \file -> do + haddocks <- allHaddocks + need haddocks + let libDocs = filter (\x -> takeFileName x /= "ghc.haddock") haddocks + context = vanillaContext Stage2 docPackage + build $ target context (Haddock BuildIndex) libDocs [file] + +allHaddocks :: Action [FilePath] +allHaddocks = do + pkgs <- stagePackages Stage1 + sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg + | pkg <- pkgs, isLibrary pkg, isHsPackage pkg ] + +haddockHtmlLib :: FilePath +haddockHtmlLib = "inplace/lib/html/haddock-util.js" + +-- | Find the haddock files for the dependencies of the current library +haddockDependencies :: Context -> Action [FilePath] +haddockDependencies context = do + path <- buildPath context + depNames <- pkgDataList $ DepNames path + sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg + | Just depPkg <- map findPackageByName depNames, depPkg /= rts ] + +-- Note: this build rule creates plenty of files, not just the .haddock one. +-- All of them go into the 'doc' subdirectory. Pedantically tracking all built +-- files in the Shake database seems fragile and unnecessary. +buildPackageDocumentation :: Context -> Rules () +buildPackageDocumentation context@Context {..} = when (stage == Stage1) $ do + + -- Js and Css files for haddock output + when (package == haddock) $ haddockHtmlLib %> \_ -> do + let dir = takeDirectory haddockHtmlLib + liftIO $ removeFiles dir ["//*"] + copyDirectory "utils/haddock/haddock-api/resources/html" dir + + -- Per-package haddocks + "//" ++ pkgName package <.> "haddock" %> \file -> do + haddocks <- haddockDependencies context + srcs <- hsSources context + need $ srcs ++ haddocks ++ [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 + "//" ++ path <.> "pdf" %> \file -> do + let context = vanillaContext Stage0 docPackage + withTempDir $ \dir -> do + build $ target context (Sphinx Latex) [pathPath path] [dir] + build $ target context Xelatex [path <.> "tex"] [dir] + copyFileUntracked (dir -/- path <.> "pdf") file + +---------------------------------------------------------------------- +-- Archive + +-- | Build archives of documentation +buildDocumentationArchives :: Rules () +buildDocumentationArchives = mapM_ buildArchive docPaths + +buildArchive :: FilePath -> Rules () +buildArchive path = do + "//" ++ pathArchive path %> \file -> do + root <- buildRoot + let context = vanillaContext Stage0 docPackage + src = root -/- pathIndex path + need [src] + build $ target context (Tar Create) [takeDirectory src] [file] + +-- | build man page +buildManPage :: Rules () +buildManPage = do + manPagePath %> \file -> do + need ["docs/users_guide/ghc.rst"] + let context = vanillaContext Stage0 docPackage + withTempDir $ \dir -> do + build $ target context (Sphinx Man) ["docs/users_guide"] [dir] + copyFileUntracked (dir -/- "ghc.1") file diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs new file mode 100644 index 0000000000..8e2b65d183 --- /dev/null +++ b/hadrian/src/Rules/Generate.hs @@ -0,0 +1,482 @@ +module Rules.Generate ( + isGeneratedCFile, isGeneratedCmmFile, generatePackageCode, generateRules, + copyRules, includesDependencies, generatedDependencies + ) where + +import Base +import Expression +import Flavour +import Oracles.Flag +import Oracles.ModuleFiles +import Oracles.Setting +import Rules.Gmp +import Rules.Libffi +import Target +import Settings +import Settings.Packages.Rts +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 = contextDir (vanillaContext stage compiler) -/- "primops.txt" + +platformH :: Stage -> FilePath +platformH stage = contextDir (vanillaContext stage compiler) -/- "ghc_boot_platform.h" + +isGeneratedCFile :: FilePath -> Bool +isGeneratedCFile file = takeBaseName file `elem` ["Evac_thr", "Scav_thr"] + +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 _) = + let dir = contextDir context + generated f = ("//" ++ dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f) + go gen file = generate file context gen + in do + 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) $ "//" -/- dir -/- "Config.hs" %> go generateConfigHs + when (pkg == ghcPkg) $ "//" -/- dir -/- "Version.hs" %> go generateVersionHs + + -- TODO: needing platformH is ugly and fragile + when (pkg == compiler) $ do + "//" ++ primopsTxt stage %> \file -> do + root <- buildRoot + need $ [root -/- platformH stage, primopsSource] + ++ fmap (root -/-) includesDependencies + build $ target context HsCpp [primopsSource] [file] + + "//" ++ platformH stage %> go generateGhcBootPlatformH + + -- TODO: why different folders for generated files? + priority 2.0 $ fmap (("//" ++ dir) -/-) + [ "GHC/Prim.hs" + , "GHC/PrimopWrappers.hs" + , "*.hs-incl" ] |%> \file -> do + root <- buildRoot + need [root -/- primopsTxt stage] + build $ target context GenPrimopCode [root -/- primopsTxt stage] [file] + + when (pkg == rts) $ "//" ++ dir -/- "cmm/AutoApply.cmm" %> \file -> + build $ target context GenApply [] [file] + +copyRules :: Rules () +copyRules = do + (inplaceLibPath -/- "ghc-usage.txt") <~ return "driver" + (inplaceLibPath -/- "ghci-usage.txt" ) <~ return "driver" + (inplaceLibPath -/- "llvm-targets") <~ return "." + (inplaceLibPath -/- "platformConstants") <~ (buildRoot <&> (-/- generatedDir)) + (inplaceLibPath -/- "settings") <~ return "." + (inplaceLibPath -/- "template-hsc.h") <~ return (pkgPath hsc2hs) + "//c/sm/Evac_thr.c" %> copyFile (pkgPath rts -/- "sm/Evac.c") + "//c/sm/Scav_thr.c" %> copyFile (pkgPath rts -/- "sm/Scav.c") + where + pattern <~ mdir = pattern %> \file -> do + dir <- mdir + copyFile (dir -/- takeFileName file) file + +generateRules :: Rules () +generateRules = do + priority 2.0 $ ("//" ++ generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH + priority 2.0 $ ("//" ++ generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH + priority 2.0 $ ("//" ++ generatedDir -/- "ghcversion.h") <~ generateGhcVersionH + + ghcSplitPath %> \_ -> do + generate ghcSplitPath emptyTarget generateGhcSplit + makeExecutable ghcSplitPath + + -- TODO: simplify, get rid of fake rts context + "//" ++ 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 <- expr $ flag 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 <- expr $ flag 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 (threaded `elem` 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 <- expr $ flag 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..46fad8a32c --- /dev/null +++ b/hadrian/src/Rules/Gmp.hs @@ -0,0 +1,119 @@ +module Rules.Gmp ( + gmpRules, gmpBuildPath, gmpObjectsDir, gmpLibraryH, gmpBuildInfoPath + ) where + +import Base +import Context +import GHC +import Oracles.Setting +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 + +-- | 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" + +-- | Path to the GMP library buildinfo file. +gmpBuildInfoPath :: FilePath +gmpBuildInfoPath = pkgPath integerGmp -/- "integer-gmp.buildinfo" + +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 + "//" ++ gmpLibraryH %> \header -> do + windows <- windowsHost + configMk <- readFile' $ gmpBase -/- "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 + "//" ++ 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 + "//" ++ gmpLibraryInTreeH %> \_ -> do + gmpPath <- gmpBuildPath + need [gmpPath -/- gmpLibraryH] + + -- This causes integerGmp package to be configured, hence creating the files + [gmpBase -/- "config.mk", gmpBuildInfoPath] &%> \_ -> do + dataFile <- pkgDataFile gmpContext + need [dataFile] + + -- Run GMP's configure script + -- TODO: Get rid of hard-coded @gmp@. + "//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 + "//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/Install.hs b/hadrian/src/Rules/Install.hs new file mode 100644 index 0000000000..bcdbf33e34 --- /dev/null +++ b/hadrian/src/Rules/Install.hs @@ -0,0 +1,336 @@ +module Rules.Install (installRules) where + +import Hadrian.Oracles.DirectoryContents +import qualified System.Directory as IO + +import Base +import Expression +import Oracles.Setting +import Rules +import Rules.Generate +import Rules.Libffi +import Rules.Wrappers +import Settings +import Settings.Packages.Rts +import Target +import Utilities + +{- | Install the built binaries etc. to the @destDir ++ prefix@. + +The installation prefix is usually @/usr/local@ on a Unix system. +The resulting tree structure is organized under @destDir ++ prefix@ as follows: + +* @bin@: executable wrapper scripts, installed by 'installBins', e.g. @ghc@. + +* @lib/ghc-<version>/bin@: executable binaries/scripts, + installed by 'installLibExecs' and 'installLibExecScripts'. + +* @lib/ghc-<version>/include@: headers etc., installed by 'installIncludes'. + +* @lib/ghc-<version>/<pkg-name>@: built packages, e.g. @base@, installed + by 'installPackages'. + +* @lib/ghc-<version>/settings@ etc.: other files in @lib@ directory, + installed by 'installCommonLibs'. + +XXX (izgzhen): Do we need @INSTALL_OPTS@ in the make scripts? +-} +installRules :: Rules () +installRules = + "install" ~> do + installIncludes + installPackageConf + installCommonLibs + installLibExecs + installLibExecScripts + installBins + installPackages + installDocs + +-- TODO: Get rid of hard-coded list. +-- | Binaries to install. +installBinPkgs :: [Package] +installBinPkgs = [ghc, ghcPkg, ghcSplit, hp2ps, hpc, hsc2hs, runGhc, unlit] + +getLibExecDir :: Action FilePath +getLibExecDir = (-/- "bin") <$> installGhcLibDir + +-- ref: ghc.mk +-- | Install executable scripts to @prefix/lib/bin@. +installLibExecScripts :: Action () +installLibExecScripts = do + libExecDir <- getLibExecDir + destDir <- getDestDir + installDirectory (destDir ++ libExecDir) + forM_ libExecScripts $ \script -> installScript script (destDir ++ libExecDir) + where + libExecScripts :: [FilePath] + libExecScripts = [ghcSplitPath] + +-- ref: ghc.mk +-- | Install executable binaries to @prefix/lib/bin@. +installLibExecs :: Action () +installLibExecs = do + libExecDir <- getLibExecDir + destDir <- getDestDir + installDirectory (destDir ++ libExecDir) + forM_ installBinPkgs $ \pkg -> + withInstallStage pkg $ \stage -> do + context <- programContext stage pkg + let bin = inplaceLibBinPath -/- programName context <.> exe + installProgram bin (destDir ++ libExecDir) + when (pkg == ghc) $ + moveFile (destDir ++ libExecDir -/- programName context <.> exe) + (destDir ++ libExecDir -/- "ghc" <.> exe) + +-- ref: ghc.mk +-- | Install executable wrapper scripts to @prefix/bin@. +installBins :: Action () +installBins = do + binDir <- setting InstallBinDir + libDir <- installGhcLibDir + destDir <- getDestDir + installDirectory (destDir ++ binDir) + win <- windowsHost + when win $ + copyDirectoryContents matchAll (destDir ++ libDir -/- "bin") (destDir ++ binDir) + unless win $ forM_ installBinPkgs $ \pkg -> + withInstallStage pkg $ \stage -> do + context <- programContext stage pkg + version <- setting ProjectVersion + -- Name of the binary file + let binName | pkg == ghc = "ghc-" ++ version <.> exe + | otherwise = programName context ++ "-" ++ version <.> exe + -- Name of the symbolic link + let symName | pkg == ghc = "ghc" <.> exe + | otherwise = programName context <.> exe + case lookup context installWrappers of + Nothing -> return () + Just wrapper -> do + contents <- interpretInContext context $ + wrapper (WrappedBinary (destDir ++ libDir) symName) + let wrapperPath = destDir ++ binDir -/- binName + writeFileChanged wrapperPath contents + makeExecutable wrapperPath + unlessM windowsHost $ + linkSymbolic (destDir ++ binDir -/- binName) + (destDir ++ binDir -/- symName) + +-- | Perform an action depending on the install stage or do nothing if the +-- package is not installed. +withInstallStage :: Package -> (Stage -> Action ()) -> Action () +withInstallStage pkg m = do + maybeStage <- installStage pkg + case maybeStage of { Just stage -> m stage; Nothing -> return () } + +pkgConfInstallPath :: Action FilePath +pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) <&> (-/- "package.conf.install") + +-- ref: rules/manual-package-conf.mk +-- TODO: Should we use a temporary file instead of pkgConfInstallPath? +-- | Install @package.conf.install@ for each package. Note that it will be +-- recreated each time. +installPackageConf :: Action () +installPackageConf = do + let context = vanillaContext Stage0 rts + confPath <- pkgConfInstallPath + liftIO $ IO.createDirectoryIfMissing True (takeDirectory confPath) + build $ target context HsCpp [ pkgPath rts -/- "package.conf.in" ] + [ confPath <.> "raw" ] + Stdout content <- cmd "grep" [ "-v", "^#pragma GCC" + , confPath <.> "raw" ] + withTempFile $ \tmp -> do + liftIO $ writeFile tmp content + Stdout result <- cmd "sed" [ "-e", "s/\"\"//g", "-e", "s/:[ ]*,/: /g", tmp ] + liftIO $ writeFile confPath result + +-- ref: ghc.mk +-- | Install packages to @prefix/lib@. +installPackages :: Action () +installPackages = do + confPath <- pkgConfInstallPath + need [confPath] + + ghcLibDir <- installGhcLibDir + binDir <- setting InstallBinDir + destDir <- getDestDir + + -- Install package.conf + let installedPackageConf = destDir ++ ghcLibDir -/- "package.conf.d" + installDirectory (destDir ++ ghcLibDir) + removeDirectory installedPackageConf + installDirectory installedPackageConf + + -- Install RTS + let rtsDir = destDir ++ ghcLibDir -/- "rts" + installDirectory rtsDir + ways <- interpretInContext (vanillaContext Stage1 rts) getRtsWays + rtsLibs <- mapM (pkgLibraryFile . Context Stage1 rts) ways + ffiLibs <- mapM rtsLibffiLibrary ways + + -- TODO: Add dynamic libraries. + forM_ (rtsLibs ++ ffiLibs) $ \lib -> installData [lib] rtsDir + + -- TODO: Remove this hack required for @ghc-cabal copy@. + -- See https://github.com/snowleopard/hadrian/issues/327. + ghcBootPlatformHeader <- + buildPath (vanillaContext Stage1 compiler) <&> (-/- "ghc_boot_platform.h") + copyFile ghcBootPlatformHeader (pkgPath compiler -/- "ghc_boot_platform.h") + + installPackages <- filterM ((isJust <$>) . installStage) + (knownPackages \\ [rts, libffi]) + + installLibPkgs <- topsortPackages (filter isLibrary installPackages) + + -- TODO: Figure out what is the root cause of the missing ghc-gmp.h error. + copyFile (pkgPath integerGmp -/- "gmp/ghc-gmp.h") (pkgPath integerGmp -/- "ghc-gmp.h") + + forM_ installLibPkgs $ \pkg -> + case pkgCabalFile pkg of + Nothing -> error $ "Non-Haskell project in installLibPkgs" ++ show pkg + Just cabalFile -> withInstallStage pkg $ \stage -> do + let context = vanillaContext stage pkg + top <- topDirectory + installDistDir <- buildPath context + let absInstallDistDir = top -/- installDistDir + + need =<< packageTargets True stage pkg + docDir <- installDocDir + ghclibDir <- installGhcLibDir + + -- Copy over packages + strip <- stripCmdPath + ways <- interpretInContext context getLibraryWays + -- TODO: Remove hard-coded @ghc-cabal@ path. + let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal" <.> exe + need [ghcCabalInplace] + + pkgConf <- pkgConfFile context + need [cabalFile, pkgConf] -- TODO: Check if we need 'pkgConf'. + + -- TODO: Drop redundant copies required by @ghc-cabal@. + -- See https://github.com/snowleopard/hadrian/issues/318. + quietly $ copyDirectoryContentsUntracked (Not excluded) + installDistDir (installDistDir -/- "build") + + pref <- setting InstallPrefix + unit $ cmd ghcCabalInplace [ "copy" + , pkgPath pkg + , absInstallDistDir + , strip + , destDir + , pref + , ghclibDir + , docDir -/- "html/libraries" + , unwords (map show ways) ] + + -- Register packages + let installedGhcPkgReal = destDir ++ binDir -/- "ghc-pkg" <.> exe + installedGhcReal = destDir ++ binDir -/- "ghc" <.> exe + -- TODO: Extend GhcPkg builder args to support --global-package-db + unit $ cmd installedGhcPkgReal [ "--force", "--global-package-db" + , installedPackageConf, "update" + , confPath ] + + forM_ installLibPkgs $ \pkg -> + withInstallStage pkg $ \stage -> do + let context = vanillaContext stage pkg + top <- topDirectory + installDistDir <- (top -/-) <$> buildPath context + -- TODO: better reference to the built inplace binary path + let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal" + pref <- setting InstallPrefix + docDir <- installDocDir + r <- relocatableBuild + unit $ cmd ghcCabalInplace + [ "register" + , pkgPath pkg + , installDistDir + , installedGhcReal + , installedGhcPkgReal + , destDir ++ ghcLibDir + , destDir + , destDir ++ pref + , destDir ++ ghcLibDir + , destDir ++ docDir -/- "html/libraries" + , if r then "YES" else "NO" ] + + confs <- getDirectoryContents installedPackageConf + forM_ confs (\f -> createData $ installedPackageConf -/- f) + unit $ cmd installedGhcPkgReal [ "--force", "--global-package-db" + , installedPackageConf, "recache" ] + where + createData f = unit $ cmd "chmod" [ "644", f ] + excluded = Or [ Test "//haddock-prologue.txt" + , Test "//package-data.mk" + , Test "//setup-config" + , Test "//inplace-pkg-config" + , Test "//build" ] + +-- ref: ghc.mk +-- | Install settings etc. files to @prefix/lib@. +installCommonLibs :: Action () +installCommonLibs = do + ghcLibDir <- installGhcLibDir + destDir <- getDestDir + installLibsTo inplaceLibCopyTargets (destDir ++ ghcLibDir) + +-- ref: ghc.mk +-- | Install library files to some path. +installLibsTo :: [FilePath] -> FilePath -> Action () +installLibsTo libs dir = do + installDirectory dir + forM_ libs $ \lib -> case takeExtension lib of + ".a" -> do + let out = dir -/- takeFileName lib + installData [out] dir + runBuilder Ranlib [out] [out] [out] + _ -> installData [lib] dir + +-- ref: includes/ghc.mk +-- | All header files are in includes/{one of these subdirectories}. +includeHSubdirs :: [FilePath] +includeHSubdirs = [".", "rts", "rts/prof", "rts/storage", "stg"] + +-- ref: includes/ghc.mk +-- | Install header files to @prefix/lib/ghc-<version>/include@. +installIncludes :: Action () +installIncludes = do + ghclibDir <- installGhcLibDir + destDir <- getDestDir + let ghcheaderDir = ghclibDir -/- "include" + installDirectory (destDir ++ ghcheaderDir) + forM_ includeHSubdirs $ \dir -> do + installDirectory (destDir ++ ghcheaderDir -/- dir) + headers <- getDirectoryFiles ("includes" -/- dir) ["*.h"] + installHeader (map (("includes" -/- dir) -/-) headers) + (destDir ++ ghcheaderDir -/- dir ++ "/") + root <- buildRoot + rtsPath <- rtsBuildPath + installHeader (fmap (root -/-) includesDependencies ++ + [root -/- generatedDir -/- "DerivedConstants.h"] ++ + fmap (rtsPath -/-) libffiDependencies) + (destDir ++ ghcheaderDir ++ "/") + where + installHeader = installData -- they share same arguments + +-- ref: ghc.mk +-- | Install documentation to @prefix/share/doc/ghc-<version>@. +installDocs :: Action () +installDocs = do + destDir <- getDestDir + docDir <- installDocDir + root <- buildRoot + installDirectory (destDir ++ docDir) + + let usersGuide = root -/- "docs/pdfs/users_guide.pdf" + whenM (doesFileExist usersGuide) $ + installData [usersGuide] (destDir ++ docDir) + + let htmlDocDir = destDir ++ docDir -/- "html" + installDirectory htmlDocDir + installData ["docs/index.html"] htmlDocDir + + forM_ ["Haddock", "libraries", "users_guide"] $ \dirname -> do + let dir = root -/- "docs/html" -/- dirname + whenM (doesDirectoryExist dir) $ copyDirectory dir htmlDocDir diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs new file mode 100644 index 0000000000..73f481d88a --- /dev/null +++ b/hadrian/src/Rules/Libffi.hs @@ -0,0 +1,108 @@ +module Rules.Libffi (libffiRules, libffiBuildPath, libffiDependencies) where + +import Hadrian.Utilities + +import Settings.Builders.Common +import Settings.Packages.Rts +import Target +import Utilities + +-- | Libffi is considered a Stage1 package. This determines its build directory. +libffiContext :: Context +libffiContext = vanillaContext Stage1 libffi + +-- | Build directory for in-tree Libffi library. +libffiBuildPath :: Action FilePath +libffiBuildPath = buildPath libffiContext + +libffiDependencies :: [FilePath] +libffiDependencies = ["ffi.h", "ffitarget.h"] + +libffiLibrary :: FilePath +libffiLibrary = "inst/lib/libffi.a" + +fixLibffiMakefile :: FilePath -> String -> String +fixLibffiMakefile top = + replace "-MD" "-MMD" + . replace "@toolexeclibdir@" "$(libdir)" + . replace "@INSTALL@" ("$(subst ../install-sh," ++ top ++ "/install-sh,@INSTALL@)") + +-- TODO: remove code duplication (see Settings/Builders/GhcCabal.hs) +-- 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 + , 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 + fmap ("//rts" -/-) libffiDependencies &%> \_ -> do + libffiPath <- libffiBuildPath + need [libffiPath -/- libffiLibrary] + + "//" ++ 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'" + + "//libffi/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@. + "//libffi/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..e6e5b167ff --- /dev/null +++ b/hadrian/src/Rules/Library.hs @@ -0,0 +1,103 @@ +module Rules.Library ( + buildPackageLibrary, buildPackageGhciLibrary, buildDynamicLib + ) where + +import Hadrian.Haskell.Cabal +import qualified System.Directory as IO + +import Base +import Context +import Expression hiding (way, package) +import Flavour +import Oracles.ModuleFiles +import Oracles.PackageData +import Oracles.Setting +import Rules.Gmp +import Settings +import Target +import Utilities + +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 + +buildDynamicLib :: Context -> Rules () +buildDynamicLib context@Context{..} = do + let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package + -- OS X + libPrefix ++ "*.dylib" %> buildDynamicLibUnix + -- Linux + libPrefix ++ "*.so" %> buildDynamicLibUnix + -- TODO: Windows + where + buildDynamicLibUnix lib = do + deps <- contextDependencies context + need =<< mapM pkgLibraryFile deps + objs <- libraryObjects context + build $ target context (Ghc LinkHs stage) objs [lib] + +buildPackageLibrary :: Context -> Rules () +buildPackageLibrary context@Context {..} = do + let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package + libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do + objs <- libraryObjects context + asuf <- libsuf way + let isLib0 = ("//*-0" ++ asuf) ?== a + removeFile a + if isLib0 then build $ target context (Ar Pack stage) [] [a] -- TODO: Scan for dlls + else build $ target context (Ar Pack stage) objs [a] + + synopsis <- traverse pkgSynopsis (pkgCabalFile package) + unless isLib0 . putSuccess $ renderLibrary + (quote (pkgName package) ++ " (" ++ show stage ++ ", way " + ++ show way ++ ").") a synopsis + +buildPackageGhciLibrary :: Context -> Rules () +buildPackageGhciLibrary context@Context {..} = priority 2 $ do + let libPrefix = "//" ++ contextDir context -/- "HS" ++ pkgName package + libPrefix ++ "*" ++ (waySuffix way <.> "o") %> \obj -> do + objs <- allObjects context + need objs + build $ target context Ld objs [obj] + +allObjects :: Context -> Action [FilePath] +allObjects context = (++) <$> nonHsObjects context <*> hsObjects context + +nonHsObjects :: Context -> Action [FilePath] +nonHsObjects context = do + path <- buildPath context + cObjs <- cObjects context + cmmSrcs <- pkgDataList (CmmSrcs path) + cmmObjs <- mapM (objectPath context) cmmSrcs + eObjs <- extraObjects context + return $ cObjs ++ cmmObjs ++ eObjs + +cObjects :: Context -> Action [FilePath] +cObjects context = do + path <- buildPath context + srcs <- pkgDataList (CSrcs path) + objs <- mapM (objectPath context) srcs + return $ if way context == threaded + then objs + else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs + +extraObjects :: Context -> Action [FilePath] +extraObjects context + | package context == integerGmp = do + gmpPath <- gmpBuildPath + need [gmpPath -/- gmpLibraryH] + map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"] + | otherwise = return [] diff --git a/hadrian/src/Rules/PackageData.hs b/hadrian/src/Rules/PackageData.hs new file mode 100644 index 0000000000..2442b03de3 --- /dev/null +++ b/hadrian/src/Rules/PackageData.hs @@ -0,0 +1,119 @@ +module Rules.PackageData (buildPackageData) where + +import Base +import Context +import Expression +import Oracles.Setting +import Rules.Generate +import Settings.Packages.Rts +import Target +import Utilities + +-- | Build @package-data.mk@ by using ghc-cabal utility to process .cabal files. +buildPackageData :: Context -> Rules () +buildPackageData context@Context {..} = do + let dir = "//" ++ contextDir context + cabalFile = unsafePkgCabalFile package -- TODO: improve + configure = pkgPath package -/- "configure" + -- TODO: Get rid of hardcoded file paths. + [dir -/- "package-data.mk", dir -/- "setup-config"] &%> \[mk, setupConfig] -> do + -- Make sure all generated dependencies are in place before proceeding. + orderOnly =<< interpretInContext context generatedDependencies + + -- GhcCabal may run the configure script, so we depend on it. + whenM (doesFileExist $ configure <.> "ac") $ need [configure] + + -- Before we configure a package its dependencies need to be registered. + need =<< mapM pkgConfFile =<< contextDependencies context + + need [cabalFile] + build $ target context GhcCabal [cabalFile] [mk, setupConfig] + postProcessPackageData context mk + + -- TODO: Get rid of hardcoded file paths. + dir -/- "inplace-pkg-config" %> \conf -> do + path <- buildPath context + dataFile <- pkgDataFile context + need [dataFile] -- ghc-cabal builds inplace package configuration file + if package == rts + then do + genPath <- buildRoot <&> (-/- generatedDir) + rtsPath <- rtsBuildPath + need [rtsConfIn] + build $ target context HsCpp [rtsConfIn] [conf] + fixFile conf $ unlines + . map + ( replace "\"\"" "" + . replace "rts/dist/build" rtsPath + . replace "includes/dist-derivedconstants/header" genPath ) + . lines + else + fixFile conf $ unlines . map (replace (path </> "build") path) . lines + + priority 2.0 $ when (nonCabalContext context) $ dir -/- "package-data.mk" %> + generatePackageData context + +generatePackageData :: Context -> FilePath -> Action () +generatePackageData context@Context {..} file = do + orderOnly =<< interpretInContext context generatedDependencies + asmSrcs <- packageAsmSources package + cSrcs <- packageCSources package + cmmSrcs <- packageCmmSources package + genPath <- buildRoot <&> (-/- generatedDir) + writeFileChanged file . unlines $ + [ "S_SRCS = " ++ unwords asmSrcs ] ++ + [ "C_SRCS = " ++ unwords cSrcs ] ++ + [ "CMM_SRCS = " ++ unwords cmmSrcs ] ++ + [ "DEP_EXTRA_LIBS = m" | package == hp2ps ] ++ + [ "CC_OPTS = -I" ++ genPath | package `elem` [hp2ps, rts]] ++ + [ "MODULES = Main" | package == ghcCabal ] ++ + [ "HS_SRC_DIRS = ." | package == ghcCabal ] + putSuccess $ "| Successfully generated " ++ file + +packageCSources :: Package -> Action [FilePath] +packageCSources pkg + | pkg /= rts = getDirectoryFiles (pkgPath pkg) ["*.c"] + | otherwise = do + windows <- windowsHost + rtsPath <- rtsBuildPath + sources <- fmap (map unifyPath) . getDirectoryFiles (pkgPath pkg) . + map (-/- "*.c") $ [ ".", "hooks", "sm", "eventlog", "linker" ] ++ + [ if windows then "win32" else "posix" ] + return $ sources ++ [ rtsPath -/- "c/sm/Evac_thr.c" ] + ++ [ rtsPath -/- "c/sm/Scav_thr.c" ] + +packageAsmSources :: Package -> Action [FilePath] +packageAsmSources pkg + | pkg /= rts = return [] + | otherwise = do + buildAdjustor <- anyTargetArch ["i386", "powerpc", "powerpc64"] + buildStgCRunAsm <- anyTargetArch ["powerpc64le"] + return $ [ "AdjustorAsm.S" | buildAdjustor ] + ++ [ "StgCRunAsm.S" | buildStgCRunAsm ] + +packageCmmSources :: Package -> Action [FilePath] +packageCmmSources pkg + | pkg /= rts = return [] + | otherwise = do + rtsPath <- rtsBuildPath + sources <- getDirectoryFiles (pkgPath pkg) ["*.cmm"] + return $ sources ++ [ rtsPath -/- "cmm/AutoApply.cmm" ] + +-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile: +-- 1) Drop lines containing '$'. For example, get rid of +-- @libraries/Win32_dist-install_CMM_SRCS := $(addprefix cbits/,$(notdir ...@ +-- and replace it with a tracked call to getDirectoryFiles. +-- 2) Drop path prefixes to individual settings. +-- For example, @libraries/deepseq/dist-install_VERSION = 1.4.0.0@ +-- is replaced by @VERSION = 1.4.0.0@. +-- Reason: Shake's built-in makefile parser doesn't recognise slashes +-- TODO (izgzhen): should fix DEP_LIB_REL_DIRS_SEARCHPATH +postProcessPackageData :: Context -> FilePath -> Action () +postProcessPackageData context@Context {..} file = do + top <- topDirectory + cmmSrcs <- getDirectoryFiles (pkgPath package) ["cbits/*.cmm"] + path <- buildPath context + let len = length (pkgPath package) + length (top -/- path) + 2 + fixFile file $ unlines + . (++ ["CMM_SRCS = " ++ unwords (map unifyPath cmmSrcs) ]) + . map (drop len) . filter ('$' `notElem`) . lines diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs new file mode 100644 index 0000000000..ba4dab0442 --- /dev/null +++ b/hadrian/src/Rules/Program.hs @@ -0,0 +1,116 @@ +module Rules.Program (buildProgram) where + +import Hadrian.Haskell.Cabal + +import Base +import Context +import Expression hiding (stage, way) +import Oracles.ModuleFiles +import Oracles.PackageData +import Oracles.Setting +import Rules.Wrappers +import Settings +import Settings.Packages.Rts +import Target +import Utilities + +-- | TODO: Drop code duplication +buildProgram :: [(Resource, Int)] -> Package -> Rules () +buildProgram rs package = do + forM_ [Stage0 ..] $ \stage -> do + let context = vanillaContext stage package + + -- Rules for programs built in 'buildRoot' + "//" ++ contextDir context -/- programName context <.> exe %> \bin -> + buildBinaryAndWrapper rs bin =<< programContext stage package + + -- Rules for the GHC package, which is built 'inplace' + when (package == ghc) $ do + inplaceBinPath -/- programName context <.> exe %> \bin -> + buildBinaryAndWrapper rs bin =<< programContext stage package + + inplaceLibBinPath -/- programName context <.> exe %> \bin -> + buildBinary rs bin =<< programContext stage package + + inplaceLibBinPath -/- programName context <.> "bin" %> \bin -> + buildBinary rs bin =<< programContext stage package + + -- Rules for other programs built in inplace directories + when (package /= ghc) $ do + let context0 = vanillaContext Stage0 package -- TODO: get rid of context0 + inplaceBinPath -/- programName context0 <.> exe %> \bin -> do + stage <- installStage package -- TODO: get rid of fromJust + buildBinaryAndWrapper rs bin =<< programContext (fromJust stage) package + + inplaceLibBinPath -/- programName context0 <.> exe %> \bin -> do + stage <- installStage package -- TODO: get rid of fromJust + context <- programContext (fromJust stage) package + if package /= iservBin then + -- We *normally* build only unwrapped binaries in inplace/lib/bin + buildBinary rs bin context + else + -- Build both binary and wrapper in inplace/lib/bin for iservBin + buildBinaryAndWrapperLib rs bin context + + inplaceLibBinPath -/- programName context0 <.> "bin" %> \bin -> do + stage <- installStage package -- TODO: get rid of fromJust + buildBinary rs bin =<< programContext (fromJust stage) package + +buildBinaryAndWrapperLib :: [(Resource, Int)] -> FilePath -> Context -> Action () +buildBinaryAndWrapperLib rs bin context = do + windows <- windowsHost + if windows + then buildBinary rs bin context -- We don't build wrappers on Windows + else case lookup context inplaceWrappers of + Nothing -> buildBinary rs bin context -- No wrapper found + Just wrapper -> do + top <- topDirectory + let libdir = top -/- inplaceLibPath + let wrappedBin = inplaceLibBinPath -/- programName context <.> "bin" + need [wrappedBin] + buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName wrappedBin)) + +buildBinaryAndWrapper :: [(Resource, Int)] -> FilePath -> Context -> Action () +buildBinaryAndWrapper rs bin context = do + windows <- windowsHost + if windows + then buildBinary rs bin context -- We don't build wrappers on Windows + else case lookup context inplaceWrappers of + Nothing -> buildBinary rs bin context -- No wrapper found + Just wrapper -> do + top <- topDirectory + let libPath = top -/- inplaceLibPath + wrappedBin = inplaceLibBinPath -/- takeFileName bin + need [wrappedBin] + buildWrapper context wrapper bin (WrappedBinary libPath (takeFileName bin)) + +buildWrapper :: Context -> Wrapper -> FilePath -> WrappedBinary -> Action () +buildWrapper context@Context {..} wrapper wrapperPath wrapped = do + contents <- interpretInContext context $ wrapper wrapped + writeFileChanged wrapperPath contents + makeExecutable wrapperPath + putSuccess $ "| Successfully created wrapper for " ++ + quote (pkgName package) ++ " (" ++ show stage ++ ")." + +-- TODO: Get rid of the Paths_hsc2hs.o hack. +buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action () +buildBinary rs bin context@Context {..} = do + binDeps <- if stage == Stage0 && package == ghcCabal + then hsSources context + else do + needLibrary =<< contextDependencies context + when (stage > Stage0) $ do + ways <- interpretInContext context (getLibraryWays <> getRtsWays) + needLibrary [ rtsContext { way = w } | w <- ways ] + path <- buildPath context + cSrcs <- pkgDataList (CSrcs path) + cObjs <- mapM (objectPath context) cSrcs + hsObjs <- hsObjects context + return $ cObjs ++ hsObjs + ++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ] + ++ [ path -/- "Paths_haddock.o" | package == haddock ] + need binDeps + buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin] + synopsis <- traverse pkgSynopsis (pkgCabalFile 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..7c0a3e00e8 --- /dev/null +++ b/hadrian/src/Rules/Register.hs @@ -0,0 +1,44 @@ +module Rules.Register (registerPackage) where + +import Base +import Context +import GHC +import Target +import Utilities + +-- TODO: Simplify. +-- | Build rules for registering packages and initialising package databases +-- by running the @ghc-pkg@ utility. +registerPackage :: [(Resource, Int)] -> Context -> Rules () +registerPackage rs context@Context {..} = do + when (stage == Stage0) $ do + -- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@ + -- pattern, therefore we need to use priorities to match the right rule. + -- TODO: Get rid of this hack. + "//" ++ stage0PackageDbDir -/- pkgName package ++ "*.conf" %%> + buildConf rs context + + when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %> + buildStamp rs context + + when (stage == Stage1) $ do + inplacePackageDbPath -/- pkgName package ++ "*.conf" %%> + buildConf rs context + + when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %> + buildStamp rs context + +buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action () +buildConf rs context@Context {..} conf = do + confIn <- pkgInplaceConfig context + need [confIn] + buildWithResources rs $ target context (GhcPkg Update stage) [confIn] [conf] + +buildStamp :: [(Resource, Int)] -> Context -> FilePath -> Action () +buildStamp rs Context {..} stamp = do + let path = takeDirectory stamp + removeDirectory path + buildWithResources rs $ + target (vanillaContext stage ghc) (GhcPkg Init stage) [] [path] + writeFileLines stamp [] + putSuccess $ "| Successfully initialised " ++ path diff --git a/hadrian/src/Rules/Selftest.hs b/hadrian/src/Rules/Selftest.hs new file mode 100644 index 0000000000..d1ffaac1c3 --- /dev/null +++ b/hadrian/src/Rules/Selftest.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Rules.Selftest (selftestRules) where + +import Test.QuickCheck + +import Base +import GHC +import Oracles.ModuleFiles +import Oracles.Setting +import Settings +import Target + +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 + 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 + +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..3143c4b153 --- /dev/null +++ b/hadrian/src/Rules/SourceDist.hs @@ -0,0 +1,113 @@ +module Rules.SourceDist (sourceDistRules) where + +import Hadrian.Oracles.DirectoryContents + +import Base +import Builder +import Oracles.Setting +import Rules.Clean + +sourceDistRules :: Rules () +sourceDistRules = do + "sdist-ghc" ~> do + -- We clean the source tree first. + -- See https://github.com/snowleopard/hadrian/issues/384. + 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..ae37343432 --- /dev/null +++ b/hadrian/src/Rules/Test.hs @@ -0,0 +1,72 @@ +module Rules.Test (testRules) where + +import Base +import Expression +import Flavour +import Oracles.Flag +import Oracles.Setting +import Settings +import Target +import Utilities + +-- TODO: clean up after testing +testRules :: Rules () +testRules = do + "validate" ~> do + need inplaceLibCopyTargets + needBuilder $ Ghc CompileHs Stage2 + needBuilder $ GhcPkg Update Stage1 + needBuilder Hpc + -- TODO: Figure out why @needBuilder Hsc2Hs@ doesn't work. + -- TODO: Eliminate explicit filepaths. + -- See https://github.com/snowleopard/hadrian/issues/376. + need ["inplace/bin/hp2ps", "inplace/bin/hsc2hs"] + build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] [] + + "test" ~> do + pkgs <- stagePackages Stage1 + tests <- filterM doesDirectoryExist $ concat + [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ] + | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ] + windows <- windowsHost + top <- topDirectory + compiler <- builderPath $ Ghc CompileHs Stage2 + ghcPkg <- builderPath $ GhcPkg Update Stage1 + haddock <- builderPath (Haddock BuildPackage) + threads <- shakeThreads <$> getShakeOptions + debugged <- ghcDebugged <$> flavour + ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen + ghcWithInterpreterInt <- fromEnum <$> ghcWithInterpreter + ghcUnregisterisedInt <- fromEnum <$> flag GhcUnregisterised + quietly . cmd "python2" $ + [ "testsuite/driver/runtests.py" ] + ++ map ("--rootdir="++) tests ++ + [ "-e", "windows=" ++ show windows + , "-e", "config.speed=2" + , "-e", "ghc_compiler_always_flags=" ++ show "-fforce-recomp -dcore-lint -dcmm-lint -dno-debug-output -no-user-package-db -rtsopts" + , "-e", "ghc_with_native_codegen=" ++ show ghcWithNativeCodeGenInt + , "-e", "ghc_debugged=" ++ show (yesNo debugged) + , "-e", "ghc_with_vanilla=1" -- TODO: do we always build vanilla? + , "-e", "ghc_with_dynamic=0" -- TODO: support dynamic + , "-e", "ghc_with_profiling=0" -- TODO: support profiling + , "-e", "ghc_with_interpreter=" ++ show ghcWithInterpreterInt + , "-e", "ghc_unregisterised=" ++ show ghcUnregisterisedInt + , "-e", "ghc_with_threaded_rts=0" -- TODO: support threaded + , "-e", "ghc_with_dynamic_rts=0" -- TODO: support dynamic + , "-e", "ghc_dynamic_by_default=False" -- TODO: support dynamic + , "-e", "ghc_dynamic=0" -- TODO: support dynamic + , "-e", "ghc_with_llvm=0" -- TODO: support LLVM + , "-e", "in_tree_compiler=True" -- TODO: when is it equal to False? + , "-e", "clean_only=False" -- TODO: do we need to support True? + , "--configfile=testsuite/config/ghc" + , "--config", "compiler=" ++ show (top -/- compiler) + , "--config", "ghc_pkg=" ++ show (top -/- ghcPkg) + , "--config", "haddock=" ++ show (top -/- haddock) + , "--summary-file", "testsuite_summary.txt" + , "--threads=" ++ show threads + ] + + -- , "--config", "hp2ps=" ++ quote ("hp2ps") + -- , "--config", "hpc=" ++ quote ("hpc") + -- , "--config", "gs=$(call quote_path,$(GS))" + -- , "--config", "timeout_prog=$(call quote_path,$(TIMEOUT_PROGRAM))" diff --git a/hadrian/src/Rules/Wrappers.hs b/hadrian/src/Rules/Wrappers.hs new file mode 100644 index 0000000000..20763a778e --- /dev/null +++ b/hadrian/src/Rules/Wrappers.hs @@ -0,0 +1,162 @@ +module Rules.Wrappers ( + WrappedBinary(..), Wrapper, inplaceWrappers, installWrappers + ) where + +import Hadrian.Oracles.Path + +import Base +import Expression +import Oracles.Setting +import Settings + +-- | Wrapper is an expression depending on (i) the 'FilePath' to the library and +-- (ii) the name of the wrapped binary. +data WrappedBinary = WrappedBinary + { binaryLibPath :: FilePath + , binaryName :: String } + +type Wrapper = WrappedBinary -> Expr String + +ghcWrapper :: WrappedBinary -> Expr String +ghcWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) + ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ] + +inplaceRunGhcWrapper :: WrappedBinary -> Expr String +inplaceRunGhcWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) + ++ " -f" ++ (binaryLibPath -/- "bin/ghc-stage2") -- TODO: use ProgramName + ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ] + +installRunGhcWrapper :: WrappedBinary -> Expr String +installRunGhcWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) + ++ " -f" ++ (binaryLibPath -/- "bin/ghc") -- TODO: use ProgramName + ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ] + +inplaceGhcPkgWrapper :: WrappedBinary -> Expr String +inplaceGhcPkgWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + top <- expr topDirectory + -- The wrapper is generated in StageN, but used in StageN+1. Therefore, we + -- always use the inplace package database, located at 'inplacePackageDbPath', + -- which is used in Stage1 and later. + bash <- expr bashPath + return $ unlines + [ "#!" ++ bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ + " --global-package-db " ++ top -/- inplacePackageDbPath ++ " ${1+\"$@\"}" ] + +installGhcPkgWrapper :: WrappedBinary -> Expr String +installGhcPkgWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + stage <- getStage + top <- expr topDirectory + -- Use the package configuration for the next stage in the wrapper. + -- The wrapper is generated in StageN, but used in StageN+1. + packageDb <- expr $ installPackageDbPath binaryLibPath top (succ stage) + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) + ++ " --global-package-db " ++ packageDb ++ " ${1+\"$@\"}" ] + +hp2psWrapper :: WrappedBinary -> Expr String +hp2psWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ] + +hpcWrapper :: WrappedBinary -> Expr String +hpcWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ] + +hsc2hsWrapper :: WrappedBinary -> Expr String +hsc2hsWrapper WrappedBinary{..} = do + top <- expr topDirectory + expr $ need [ sourcePath -/- "Rules/Wrappers.hs" ] + contents <- expr $ readFile' $ top -/- "utils/hsc2hs/hsc2hs.wrapper" + let executableName = binaryLibPath -/- "bin" -/- binaryName + confCcArgs <- expr $ settingList (ConfCcArgs Stage1) + confGccLinkerArgs <- expr $ settingList (ConfGccLinkerArgs Stage1) + let hsc2hsExtra = unwords (map ("-cflags=" ++) confCcArgs) ++ " " ++ + unwords (map ("-lflags=" ++) confGccLinkerArgs) + bash <- expr bashPath + return $ unlines + [ "#!"++bash + , "executablename=\"" ++ executableName ++ "\"" + , "HSC2HS_EXTRA=\"" ++ hsc2hsExtra ++ "\"" + , contents ] + +haddockWrapper :: WrappedBinary -> Expr String +haddockWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + return $ unlines + [ "#!/bin/bash" + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) + ++ " -B" ++ binaryLibPath ++ " -l" ++ binaryLibPath ++ " ${1+\"$@\"}" ] + +iservBinWrapper :: WrappedBinary -> Expr String +iservBinWrapper WrappedBinary{..} = do + expr $ need [sourcePath -/- "Rules/Wrappers.hs"] + stage <- getStage + stageLibraries <- expr $ filter isLibrary <$> stagePackages stage + -- TODO: Figure our the reason of this hardcoded exclusion + let pkgs = stageLibraries \\ [ cabal, process, haskeline + , terminfo, ghcCompact, hpc, compiler ] + contexts <- expr $ concatForM pkgs $ \p -> do + maybeStage <- installStage p + return [ vanillaContext s p | s <- maybeToList maybeStage ] + buildPaths <- expr $ mapM buildPath contexts + return $ unlines + [ "#!/bin/bash" + , "export DYLD_LIBRARY_PATH=\"" ++ intercalate ":" buildPaths ++ + "${DYLD_LIBRARY_PATH:+:$DYLD_LIBRARY_PATH}\"" + , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ] + +wrappersCommon :: [(Context, Wrapper)] +wrappersCommon = [ (vanillaContext Stage0 ghc , ghcWrapper) + , (vanillaContext Stage1 ghc , ghcWrapper) + , (vanillaContext Stage1 hp2ps , hp2psWrapper) + , (vanillaContext Stage1 hpc , hpcWrapper) + , (vanillaContext Stage1 hsc2hs, hsc2hsWrapper) + , (vanillaContext Stage2 haddock, haddockWrapper) + , (vanillaContext Stage1 iservBin, iservBinWrapper) ] + +-- | List of wrappers for inplace artefacts +inplaceWrappers :: [(Context, Wrapper)] +inplaceWrappers = wrappersCommon ++ + [ (vanillaContext Stage0 ghcPkg, inplaceGhcPkgWrapper) + , (vanillaContext Stage1 runGhc, inplaceRunGhcWrapper) ] + +-- | List of wrappers for installation +installWrappers :: [(Context, Wrapper)] +installWrappers = wrappersCommon ++ + [ (vanillaContext Stage0 ghcPkg, installGhcPkgWrapper) + , (vanillaContext Stage1 runGhc, installRunGhcWrapper) ] + +-- | In the final installation path specified by @DEST@, there is another +-- @package.conf.d@ different from 'inplacePackageDbPath' defined in "Base". +installPackageDbPath :: FilePath -> FilePath -> Stage -> Action FilePath +installPackageDbPath _ top Stage0 = do + path <- buildRoot + return $ top -/- path -/- "stage0/bootstrapping.conf" +installPackageDbPath libdir _ _ = return $ libdir -/- "package.conf.d" diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs new file mode 100644 index 0000000000..091efc10ca --- /dev/null +++ b/hadrian/src/Settings.hs @@ -0,0 +1,68 @@ +module Settings ( + getArgs, getLibraryWays, getRtsWays, flavour, knownPackages, + findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages, + programContext, getIntegerPackage, getDestDir + ) where + +import CommandLine +import Expression +import Flavour +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 +import UserSettings + +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 + +-- | Install's DESTDIR setting. +getDestDir :: Action FilePath +getDestDir = fromMaybe "" <$> cmdInstallDestDir 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/Cc.hs b/hadrian/src/Settings/Builders/Cc.hs new file mode 100644 index 0000000000..70d043f76d --- /dev/null +++ b/hadrian/src/Settings/Builders/Cc.hs @@ -0,0 +1,26 @@ +module Settings.Builders.Cc (ccBuilderArgs) where + +import Settings.Builders.Common + +ccBuilderArgs :: Args +ccBuilderArgs = do + way <- getWay + builder Cc ? mconcat + [ getPkgDataList CcArgs + , getStagedSettingList ConfCcArgs + , cIncludeArgs + + , builder (Cc CompileC) ? mconcat + [ pure ["-Wall", "-Werror"] + , 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" + , 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..5ca594e645 --- /dev/null +++ b/hadrian/src/Settings/Builders/Common.hs @@ -0,0 +1,59 @@ +module Settings.Builders.Common ( + module Base, + module Expression, + module Oracles.Flag, + module Oracles.PackageData, + module Oracles.Setting, + module Settings, + module UserSettings, + cIncludeArgs, ldArgs, cArgs, cWarnings, bootPackageDatabaseArgs + ) where + +import Base +import Expression +import Oracles.Flag +import Oracles.PackageData +import Oracles.Setting +import Settings +import UserSettings + +cIncludeArgs :: Args +cIncludeArgs = do + pkg <- getPackage + root <- getBuildRoot + path <- getBuildPath + incDirs <- getPkgDataList IncludeDirs + depDirs <- getPkgDataList DepIncludeDirs + cross <- expr crossCompiling + compilerOrGhc <- package compiler ||^ package ghc + mconcat [ not (cross && compilerOrGhc) ? arg "-Iincludes" + , arg $ "-I" ++ root -/- generatedDir + , arg $ "-I" ++ path + , 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 = do + let gccGe46 = notM (flag GccIsClang ||^ flag GccLt46) + mconcat [ arg "-Wall" + , flag GccIsClang ? arg "-Wno-unknown-pragmas" + , gccGe46 ? notM windowsHost ? arg "-Werror=unused-but-set-variable" + , gccGe46 ? arg "-Wno-error=inline" ] + +bootPackageDatabaseArgs :: Args +bootPackageDatabaseArgs = do + stage <- getStage + dbPath <- expr $ packageDbPath stage + expr $ need [dbPath -/- packageDbStamp] + stage0 ? do + top <- expr topDirectory + root <- getBuildRoot + prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=") + arg $ prefix ++ top -/- root -/- stage0PackageDbDir diff --git a/hadrian/src/Settings/Builders/Configure.hs b/hadrian/src/Settings/Builders/Configure.hs new file mode 100644 index 0000000000..93225b5405 --- /dev/null +++ b/hadrian/src/Settings/Builders/Configure.hs @@ -0,0 +1,25 @@ +module Settings.Builders.Configure (configureBuilderArgs) where + +import Rules.Gmp +import Rules.Libffi +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..7a6e863e9c --- /dev/null +++ b/hadrian/src/Settings/Builders/DeriveConstants.hs @@ -0,0 +1,39 @@ +module Settings.Builders.DeriveConstants (deriveConstantsBuilderArgs) where + +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..a975e7e799 --- /dev/null +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -0,0 +1,149 @@ +module Settings.Builders.Ghc (ghcBuilderArgs, haddockGhcArgs) where + +import Hadrian.Haskell.Cabal + +import Flavour +import Rules.Gmp +import Settings.Builders.Common +import Settings.Warnings + +ghcBuilderArgs :: Args +ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies] + +compileAndLinkHs :: Args +compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do + needTouchy + mconcat [ arg "-Wall" + , commonGhcArgs + , splitObjectsArgs + , ghcLinkArgs + , defaultGhcWarningsArgs + , builder (Ghc CompileHs) ? arg "-c" + , getInputs + , arg "-o", arg =<< getOutput ] + +needTouchy :: Expr () +needTouchy = notStage0 ? windowsHost ? do + touchyPath <- expr $ programPath (vanillaContext Stage0 touchy) + expr $ need [touchyPath] + +compileC :: Args +compileC = builder (Ghc CompileCWithGhc) ? do + way <- getWay + let ccArgs = [ getPkgDataList CcArgs + , 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 + stage <- getStage + way <- getWay + pkg <- getPackage + libs <- getPkgDataList DepExtraLibs + libDirs <- getPkgDataList DepLibDirs + intLib <- getIntegerPackage + gmpLibs <- if stage > Stage0 && intLib == integerGmp + then do -- TODO: get this data more gracefully + let strip = fromMaybe "" . stripPrefix "extra-libraries: " + buildInfo <- expr $ readFileLines gmpBuildInfoPath + return $ concatMap (words . strip) buildInfo + else return [] + 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 ] + , pure [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ] + +splitObjectsArgs :: Args +splitObjectsArgs = splitObjects <$> flavour ? do + expr $ need [ghcSplitPath] + arg "-split-objs" + +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, getPkgDataList HsArgs ] + +-- Used in ghcBuilderArgs, ghcCBuilderArgs, ghcMBuilderArgs and haddockGhcArgs. +commonGhcArgs :: Args +commonGhcArgs = do + way <- getWay + path <- getBuildPath + pkg <- getPackage + when (isLibrary pkg) $ do + context <- getContext + conf <- expr $ pkgConfFile context + expr $ need [conf] + mconcat [ arg "-hisuf", arg $ hisuf way + , arg "-osuf" , arg $ osuf way + , arg "-hcsuf", arg $ hcsuf way + , wayGhcArgs + , packageGhcArgs + , includeGhcArgs + , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs + , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs + , map ("-optP" ++) <$> getPkgDataList CppArgs + , 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 = withHsPackage $ \cabalFile -> do + pkgId <- expr $ pkgIdentifier cabalFile + mconcat [ arg "-hide-all-packages" + , arg "-no-user-package-db" + , bootPackageDatabaseArgs + , libraryPackage ? arg ("-this-unit-id " ++ pkgId) + , map ("-package-id " ++) <$> getPkgDataList DepIds ] + +includeGhcArgs :: Args +includeGhcArgs = do + pkg <- getPackage + path <- getBuildPath + root <- getBuildRoot + context <- getContext + srcDirs <- getPkgDataList 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 + , (not $ nonCabalContext context) ? + pure [ "-optP-include", "-optP" ++ autogen -/- "cabal_macros.h" ] ] diff --git a/hadrian/src/Settings/Builders/GhcCabal.hs b/hadrian/src/Settings/Builders/GhcCabal.hs new file mode 100644 index 0000000000..bfb84a76ec --- /dev/null +++ b/hadrian/src/Settings/Builders/GhcCabal.hs @@ -0,0 +1,118 @@ +module Settings.Builders.GhcCabal ( + ghcCabalBuilderArgs + ) where + +import Hadrian.Haskell.Cabal + +import Context +import Flavour +import Settings.Builders.Common + +ghcCabalBuilderArgs :: Args +ghcCabalBuilderArgs = builder GhcCabal ? do + verbosity <- expr getVerbosity + top <- expr topDirectory + path <- getBuildPath + notStage0 ? expr (need inplaceLibCopyTargets) + mconcat [ arg "configure" + , arg =<< pkgPath <$> getPackage + , arg $ top -/- path + , withStaged $ Ghc CompileHs + , withStaged (GhcPkg Update) + , bootPackageDatabaseArgs + , libraryArgs + , configureArgs + , bootPackageConstraints + , withStaged $ Cc CompileC + , notStage0 ? with Ld + , 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? +libraryArgs :: Args +libraryArgs = do + ways <- getLibraryWays + withGhci <- expr ghcWithInterpreter + dynPrograms <- dynamicGhcPrograms <$> expr flavour + 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 profiling `elem` ways + then "--enable-library-profiling" + else "--disable-library-profiling" + , if dynamic `elem` ways + then "--enable-shared" + else "--disable-shared" ] + +-- TODO: LD_OPTS? +configureArgs :: Args +configureArgs = do + top <- expr topDirectory + root <- getBuildRoot + 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 ] + 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 + , crossCompiling ? (conf "--host" $ arg =<< getSetting TargetPlatformFull) + , conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage ] + +bootPackageConstraints :: Args +bootPackageConstraints = stage0 ? do + bootPkgs <- expr $ stagePackages Stage0 + let pkgs = filter (\p -> p /= compiler && isLibrary p) bootPkgs + constraints <- expr $ fmap catMaybes $ forM (sort pkgs) $ \pkg -> do + version <- traverse pkgVersion (pkgCabalFile pkg) + return $ fmap ((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 + +-- 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/GhcPkg.hs b/hadrian/src/Settings/Builders/GhcPkg.hs new file mode 100644 index 0000000000..ba705c6892 --- /dev/null +++ b/hadrian/src/Settings/Builders/GhcPkg.hs @@ -0,0 +1,17 @@ +module Settings.Builders.GhcPkg (ghcPkgBuilderArgs) where + +import Settings.Builders.Common + +ghcPkgBuilderArgs :: Args +ghcPkgBuilderArgs = mconcat + [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ] + + , builder (GhcPkg Update) ? do + verbosity <- expr getVerbosity + context <- getContext + config <- expr $ pkgInplaceConfig context + mconcat [ 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..b3810476ad --- /dev/null +++ b/hadrian/src/Settings/Builders/Haddock.hs @@ -0,0 +1,63 @@ +module Settings.Builders.Haddock (haddockBuilderArgs) where + +import Hadrian.Utilities +import Hadrian.Haskell.Cabal + +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 s = case map read . words $ replaceEq '.' ' ' s of + [major, minor, patch] -> major * 1000 + minor * 10 + patch + _ -> error "versionToInt: cannot parse version." + +haddockBuilderArgs :: Args +haddockBuilderArgs = withHsPackage $ \cabalFile -> mconcat + [ builder (Haddock BuildIndex) ? do + output <- getOutput + inputs <- getInputs + mconcat + [ 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 + path <- getBuildPath + version <- expr $ pkgVersion cabalFile + synopsis <- expr $ pkgSynopsis cabalFile + deps <- getPkgDataList DepNames + haddocks <- expr . haddockDependencies =<< getContext + hVersion <- expr $ pkgVersion (unsafePkgCabalFile haddock) -- TODO: improve + ghcOpts <- haddockGhcArgs + mconcat + [ arg $ "--odir=" ++ takeDirectory output + , arg "--verbosity=0" + , arg "--no-tmp-comp-dir" + , arg $ "--dump-interface=" ++ output + , arg "--html" + , arg "--hyperlinked-source" + , arg "--hoogle" + , arg $ "--title=" ++ pkgName pkg ++ "-" ++ version + ++ ": " ++ synopsis + , arg $ "--prologue=" ++ path -/- "haddock-prologue.txt" + , arg $ "--optghc=-D__HADDOCK_VERSION__=" + ++ show (versionToInt hVersion) + , map ("--hide=" ++) <$> getPkgDataList HiddenModules + , pure [ "--read-interface=../" ++ dep + ++ ",../" ++ dep ++ "/src/%{MODULE}.html#%{NAME}," + ++ haddock | (dep, haddock) <- zip deps haddocks ] + , pure [ "--optghc=" ++ opt | opt <- ghcOpts ] + , 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..aeb5255990 --- /dev/null +++ b/hadrian/src/Settings/Builders/HsCpp.hs @@ -0,0 +1,16 @@ +module Settings.Builders.HsCpp (hsCppBuilderArgs) where + +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..6185f6bec3 --- /dev/null +++ b/hadrian/src/Settings/Builders/Hsc2Hs.hs @@ -0,0 +1,56 @@ +module Settings.Builders.Hsc2Hs (hsc2hsBuilderArgs) where + +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 + mconcat [ arg $ "--cc=" ++ ccPath + , arg $ "--ld=" ++ ccPath + , notM windowsHost ? arg "--cross-safe" + , pure $ map ("-I" ++) (words gmpDir) + , map ("--cflag=" ++) <$> getCFlags + , map ("--lflag=" ++) <$> getLFlags + , notStage0 ? 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=" ++ top -/- templateHscPath + , arg $ "-I" ++ top -/- "inplace/lib/include/" + , 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 + , getPkgDataList CppArgs + , getPkgDataList DepCcArgs + , cWarnings + , arg "-include", arg $ autogen -/- "cabal_macros.h" ] + +getLFlags :: Expr [String] +getLFlags = do + libDirs <- getPkgDataList DepLibDirs + extraLibs <- getPkgDataList DepExtraLibs + mconcat [ getStagedSettingList ConfGccLinkerArgs + , ldArgs + , getPkgDataList LdArgs + , pure [ "-L" ++ unifyPath dir | dir <- libDirs ] + , pure [ "-l" ++ unifyPath dir | dir <- extraLibs ] + , getPkgDataList DepLdArgs ] 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..cc350df508 --- /dev/null +++ b/hadrian/src/Settings/Builders/Make.hs @@ -0,0 +1,16 @@ +module Settings.Builders.Make (makeBuilderArgs) where + +import Rules.Gmp +import Rules.Libffi +import Settings.Builders.Common + +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"] + , builder (Make "testsuite/tests") ? pure ["THREADS=" ++ t, "fast"] ] 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..dc58f22160 --- /dev/null +++ b/hadrian/src/Settings/Default.hs @@ -0,0 +1,173 @@ +module Settings.Default ( + SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs, + defaultArgs, defaultLibraryWays, defaultRtsWays, + defaultFlavour, defaultSplitObjects + ) where + +import qualified Hadrian.Builder.Ar +import qualified Hadrian.Builder.Sphinx +import qualified Hadrian.Builder.Tar + +import CommandLine +import Expression +import Flavour +import Oracles.Flag +import Oracles.PackageData +import Settings +import Settings.Builders.Alex +import Settings.Builders.DeriveConstants +import Settings.Builders.Cc +import Settings.Builders.Configure +import Settings.Builders.GenPrimopCode +import Settings.Builders.Ghc +import Settings.Builders.GhcCabal +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.Xelatex +import Settings.Packages.Base +import Settings.Packages.Cabal +import Settings.Packages.Compiler +import Settings.Packages.Ghc +import Settings.Packages.GhcCabal +import Settings.Packages.Ghci +import Settings.Packages.GhcPkg +import Settings.Packages.GhcPrim +import Settings.Packages.Haddock +import Settings.Packages.Haskeline +import Settings.Packages.IntegerGmp +import Settings.Packages.Rts +import Settings.Packages.RunGhc +import Settings.Warnings + +-- 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 + , getPkgDataList HsArgs + , 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 } + +-- | 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 = do + ways <- getLibraryWays + mconcat + [ pure [ logging, debug, threaded, threadedDebug, threadedLogging ] + , (profiling `elem` ways) ? pure [threadedProfiling] + , (dynamic `elem` ways) ? + pure [ dynamic, debugDynamic, threadedDynamic, threadedDebugDynamic + , loggingDynamic, threadedLoggingDynamic ] ] + +-- 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 = False + , ghciWithDebugger = False + , ghcProfiled = False + , ghcDebugged = False } + +-- | 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 + , ccBuilderArgs + , configureBuilderArgs + , deriveConstantsBuilderArgs + , genPrimopCodeBuilderArgs + , ghcBuilderArgs + , ghcCabalBuilderArgs + , ghcPkgBuilderArgs + , haddockBuilderArgs + , happyBuilderArgs + , hsc2hsBuilderArgs + , hsCppBuilderArgs + , ldBuilderArgs + , makeBuilderArgs + , 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 + [ basePackageArgs + , cabalPackageArgs + , compilerPackageArgs + , ghcCabalPackageArgs + , ghciPackageArgs + , ghcPackageArgs + , ghcPkgPackageArgs + , ghcPrimPackageArgs + , haddockPackageArgs + , haskelinePackageArgs + , integerGmpPackageArgs + , rtsPackageArgs + , runGhcPackageArgs + , warningArgs ] diff --git a/hadrian/src/Settings/Default.hs-boot b/hadrian/src/Settings/Default.hs-boot new file mode 100644 index 0000000000..468c5cae3e --- /dev/null +++ b/hadrian/src/Settings/Default.hs-boot @@ -0,0 +1,20 @@ +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/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..d56cc10055 --- /dev/null +++ b/hadrian/src/Settings/Flavours/Profiled.hs @@ -0,0 +1,19 @@ +module Settings.Flavours.Profiled (profiledFlavour) where + +import Expression +import Flavour +import {-# SOURCE #-} Settings.Default + +-- 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 = pure ["-O0", "-H64m"] + , 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..99dade9bf1 --- /dev/null +++ b/hadrian/src/Settings/Flavours/Quick.hs @@ -0,0 +1,22 @@ +module Settings.Flavours.Quick (quickFlavour) where + +import Expression +import Flavour +import Oracles.Flag +import {-# SOURCE #-} Settings.Default + +-- 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] ] } + +quickArgs :: Args +quickArgs = sourceArgs SourceArgs + { hsDefault = pure ["-O0", "-H64m"] + , 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..3d0c410bea --- /dev/null +++ b/hadrian/src/Settings/Flavours/QuickCross.hs @@ -0,0 +1,24 @@ +module Settings.Flavours.QuickCross (quickCrossFlavour) where + +import Expression +import Flavour +import Oracles.Flag +import {-# SOURCE #-} Settings.Default + +-- Please update doc/flavours.md when changing this file. +quickCrossFlavour :: Flavour +quickCrossFlavour = defaultFlavour + { name = "quick-cross" + , args = defaultBuilderArgs <> quickCrossArgs <> defaultPackageArgs + , libraryWays = mconcat + [ pure [vanilla] + , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] } + +quickCrossArgs :: Args +quickCrossArgs = sourceArgs SourceArgs + { hsDefault = pure ["-O0", "-H64m"] + , 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..a9dfb7087f --- /dev/null +++ b/hadrian/src/Settings/Flavours/Quickest.hs @@ -0,0 +1,23 @@ +module Settings.Flavours.Quickest (quickestFlavour) where + +import Expression +import Flavour +import {-# SOURCE #-} Settings.Default + +-- Please update doc/flavours.md when changing this file. +quickestFlavour :: Flavour +quickestFlavour = defaultFlavour + { name = "quickest" + , args = defaultBuilderArgs <> quickestArgs <> defaultPackageArgs + , libraryWays = pure [vanilla] + , rtsWays = quickestRtsWays } + +quickestArgs :: Args +quickestArgs = sourceArgs SourceArgs + { hsDefault = pure ["-O0", "-H64m"] + , hsLibrary = mempty + , hsCompiler = stage0 ? arg "-O" + , hsGhc = stage0 ? arg "-O" } + +quickestRtsWays :: Ways +quickestRtsWays = pure [vanilla, threaded] diff --git a/hadrian/src/Settings/Packages/Base.hs b/hadrian/src/Settings/Packages/Base.hs new file mode 100644 index 0000000000..2e0ced4c26 --- /dev/null +++ b/hadrian/src/Settings/Packages/Base.hs @@ -0,0 +1,12 @@ +module Settings.Packages.Base (basePackageArgs) where + +import Expression +import Settings + +basePackageArgs :: Args +basePackageArgs = package base ? do + integerLibraryName <- pkgName <$> getIntegerPackage + mconcat [ builder GhcCabal ? arg ("--flags=" ++ integerLibraryName) + -- This fixes the 'unknown symbol stat' issue. + -- See: https://github.com/snowleopard/hadrian/issues/259. + , builder (Ghc CompileCWithGhc) ? arg "-optc-O2" ] diff --git a/hadrian/src/Settings/Packages/Cabal.hs b/hadrian/src/Settings/Packages/Cabal.hs new file mode 100644 index 0000000000..c01be4b3ed --- /dev/null +++ b/hadrian/src/Settings/Packages/Cabal.hs @@ -0,0 +1,10 @@ +module Settings.Packages.Cabal where + +import Expression + +cabalPackageArgs :: Args +cabalPackageArgs = package cabal ? + -- Cabal is a rather large library and quite 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 optimize it. + stage0 ? builder Ghc ? arg "-O0" diff --git a/hadrian/src/Settings/Packages/Compiler.hs b/hadrian/src/Settings/Packages/Compiler.hs new file mode 100644 index 0000000000..6b329d7b4f --- /dev/null +++ b/hadrian/src/Settings/Packages/Compiler.hs @@ -0,0 +1,45 @@ +module Settings.Packages.Compiler (compilerPackageArgs) where + +import Base +import Expression +import Flavour +import Oracles.Flag +import Oracles.Setting +import Settings + +compilerPackageArgs :: Args +compilerPackageArgs = package compiler ? do + stage <- getStage + rtsWays <- getRtsWays + path <- getBuildPath + mconcat [ builder Alex ? arg "--latin1" + + , builder (Ghc CompileHs) ? mconcat + [ inputs ["//GHC.hs", "//GhcMake.hs"] ? arg "-fprof-auto" + , input "//Parser.hs" ? + pure ["-O0", "-fno-ignore-interface-pragmas", "-fcmm-sink" ] ] + + , builder GhcCabal ? 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" + , (threaded `elem` rtsWays) ? + notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS" + , ghcWithNativeCodeGen ? arg "--flags=ncg" + , ghcWithInterpreter ? + notStage0 ? arg "--flags=ghci" + , crossCompiling ? arg "-f-terminfo" + , 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 (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] diff --git a/hadrian/src/Settings/Packages/Ghc.hs b/hadrian/src/Settings/Packages/Ghc.hs new file mode 100644 index 0000000000..d7b1d78ddd --- /dev/null +++ b/hadrian/src/Settings/Packages/Ghc.hs @@ -0,0 +1,13 @@ +module Settings.Packages.Ghc (ghcPackageArgs) where + +import Expression +import Oracles.Setting +import Oracles.Flag (crossCompiling) + +ghcPackageArgs :: Args +ghcPackageArgs = package ghc ? do + stage <- getStage + path <- expr $ buildPath (vanillaContext stage compiler) + mconcat [ builder Ghc ? arg ("-I" ++ path) + , builder GhcCabal ? ghcWithInterpreter ? notStage0 ? arg "--flags=ghci" + , builder GhcCabal ? crossCompiling ? arg "-f-terminfo" ] diff --git a/hadrian/src/Settings/Packages/GhcCabal.hs b/hadrian/src/Settings/Packages/GhcCabal.hs new file mode 100644 index 0000000000..7d2e99e536 --- /dev/null +++ b/hadrian/src/Settings/Packages/GhcCabal.hs @@ -0,0 +1,24 @@ +module Settings.Packages.GhcCabal (ghcCabalPackageArgs) where + +import Hadrian.Haskell.Cabal + +import Base +import Expression +import Utilities + +ghcCabalPackageArgs :: Args +ghcCabalPackageArgs = stage0 ? package ghcCabal ? builder Ghc ? do + cabalDeps <- expr $ stage1Dependencies cabal + cabalVersion <- expr $ pkgVersion (unsafePkgCabalFile cabal) -- TODO: improve + mconcat + [ pure [ "-package " ++ pkgName pkg | pkg <- cabalDeps, pkg /= parsec ] + , arg "--make" + , arg "-j" + , pure ["-Wall", "-fno-warn-unused-imports", "-fno-warn-warnings-deprecations"] + , arg ("-DCABAL_VERSION=" ++ replace "." "," cabalVersion) + , arg "-DBOOTSTRAPPING" + , arg "-DMIN_VERSION_binary_0_8_0" + , arg "-ilibraries/Cabal/Cabal" + , arg "-ilibraries/binary/src" + , arg "-ilibraries/filepath" + , arg "-ilibraries/hpc" ] diff --git a/hadrian/src/Settings/Packages/GhcPkg.hs b/hadrian/src/Settings/Packages/GhcPkg.hs new file mode 100644 index 0000000000..a13a9dab7e --- /dev/null +++ b/hadrian/src/Settings/Packages/GhcPkg.hs @@ -0,0 +1,7 @@ +module Settings.Packages.GhcPkg (ghcPkgPackageArgs) where + +import Expression +import Oracles.Flag (crossCompiling) + +ghcPkgPackageArgs :: Args +ghcPkgPackageArgs = package ghcPkg ? builder GhcCabal ? crossCompiling ? arg "-f-terminfo" diff --git a/hadrian/src/Settings/Packages/GhcPrim.hs b/hadrian/src/Settings/Packages/GhcPrim.hs new file mode 100644 index 0000000000..df1c553d25 --- /dev/null +++ b/hadrian/src/Settings/Packages/GhcPrim.hs @@ -0,0 +1,13 @@ +module Settings.Packages.GhcPrim (ghcPrimPackageArgs) where + +import Oracles.Flag +import Expression + +ghcPrimPackageArgs :: Args +ghcPrimPackageArgs = package ghcPrim ? mconcat + [ builder GhcCabal ? arg "--flag=include-ghc-prim" + + , builder (Cc CompileC) ? + (not <$> flag GccLt44) ? + (not <$> flag GccIsClang) ? + input "//cbits/atomic.c" ? arg "-Wno-sync-nand" ] diff --git a/hadrian/src/Settings/Packages/Ghci.hs b/hadrian/src/Settings/Packages/Ghci.hs new file mode 100644 index 0000000000..47e7d38deb --- /dev/null +++ b/hadrian/src/Settings/Packages/Ghci.hs @@ -0,0 +1,6 @@ +module Settings.Packages.Ghci (ghciPackageArgs) where + +import Expression + +ghciPackageArgs :: Args +ghciPackageArgs = package ghci ? notStage0 ? builder GhcCabal ? arg "--flags=ghci" diff --git a/hadrian/src/Settings/Packages/Haddock.hs b/hadrian/src/Settings/Packages/Haddock.hs new file mode 100644 index 0000000000..c8d667ecb4 --- /dev/null +++ b/hadrian/src/Settings/Packages/Haddock.hs @@ -0,0 +1,7 @@ +module Settings.Packages.Haddock (haddockPackageArgs) where + +import Expression + +haddockPackageArgs :: Args +haddockPackageArgs = package haddock ? + builder GhcCabal ? pure ["--flag", "in-ghc-tree"] diff --git a/hadrian/src/Settings/Packages/Haskeline.hs b/hadrian/src/Settings/Packages/Haskeline.hs new file mode 100644 index 0000000000..254c6b704c --- /dev/null +++ b/hadrian/src/Settings/Packages/Haskeline.hs @@ -0,0 +1,8 @@ +module Settings.Packages.Haskeline (haskelinePackageArgs) where + +import Expression +import Oracles.Flag (crossCompiling) + +haskelinePackageArgs :: Args +haskelinePackageArgs = + package haskeline ? builder GhcCabal ? crossCompiling ? arg "-f-terminfo" diff --git a/hadrian/src/Settings/Packages/IntegerGmp.hs b/hadrian/src/Settings/Packages/IntegerGmp.hs new file mode 100644 index 0000000000..7c2b5f635b --- /dev/null +++ b/hadrian/src/Settings/Packages/IntegerGmp.hs @@ -0,0 +1,24 @@ +module Settings.Packages.IntegerGmp (integerGmpPackageArgs) where + +import Base +import Expression +import Oracles.Setting +import Rules.Gmp + +-- TODO: Is this needed? +-- ifeq "$(GMP_PREFER_FRAMEWORK)" "YES" +-- libraries/integer-gmp_CONFIGURE_OPTS += --with-gmp-framework-preferred +-- endif +integerGmpPackageArgs :: Args +integerGmpPackageArgs = package integerGmp ? do + path <- expr gmpBuildPath + let includeGmp = "-I" ++ path -/- "include" + gmpIncludeDir <- getSetting GmpIncludeDir + gmpLibDir <- getSetting GmpLibDir + mconcat [ builder Cc ? arg includeGmp + + , builder GhcCabal ? mconcat + [ (null gmpIncludeDir && null gmpLibDir) ? + arg "--configure-option=--with-intree-gmp" + , arg ("--configure-option=CFLAGS=" ++ includeGmp) + , arg ("--gcc-options=" ++ includeGmp) ] ] diff --git a/hadrian/src/Settings/Packages/Rts.hs b/hadrian/src/Settings/Packages/Rts.hs new file mode 100644 index 0000000000..33169fe78b --- /dev/null +++ b/hadrian/src/Settings/Packages/Rts.hs @@ -0,0 +1,218 @@ +module Settings.Packages.Rts ( + rtsContext, rtsBuildPath, rtsConfIn, rtsPackageArgs, rtsLibffiLibrary + ) where + +import Base +import Expression +import Oracles.Flag +import Oracles.Setting +import Settings + +-- | RTS is considered a Stage1 package. This determines RTS build directory. +rtsContext :: Context +rtsContext = vanillaContext Stage1 rts + +-- | Path to the RTS build directory. +rtsBuildPath :: Action FilePath +rtsBuildPath = buildPath rtsContext + +-- | Path to RTS package configuration file, to be processed by HsCpp. +rtsConfIn :: FilePath +rtsConfIn = pkgPath rts -/- "package.conf.in" + +-- 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" + +libffiLibraryName :: Action FilePath +libffiLibraryName = do + useSystemFfi <- flag UseSystemFfi + windows <- windowsHost + return $ case (useSystemFfi, windows) of + (True , False) -> "ffi" + (False, False) -> "Cffi" + (_ , True ) -> "Cffi-6" + +rtsLibffiLibrary :: Way -> Action FilePath +rtsLibffiLibrary way = do + name <- libffiLibraryName + suf <- libsuf way + rtsPath <- rtsBuildPath + return $ rtsPath -/- "lib" ++ name ++ suf + +-- 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 + +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 + way <- getWay + path <- getBuildPath + top <- expr topDirectory + libffiName <- expr libffiLibraryName + ffiIncludeDir <- getSetting FfiIncludeDir + ffiLibraryDir <- getSetting FfiLibDir + ghclibDir <- expr installGhcLibDir + destDir <- expr getDestDir + let cArgs = mconcat + [ arg "-Irts" + , rtsWarnings + , arg $ "-I" ++ path + , flag UseSystemFfi ? arg ("-I" ++ ffiIncludeDir) + , arg $ "-DRtsWay=\"rts_" ++ show way ++ "\"" + -- 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" + + , Debug `wayUnit` way ? arg "-DDEBUG" + , 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 ] + + , 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 also necessary for these bits, 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" + , inputs ["//RetainerSet.c"] ? arg "-Wno-format" + -- 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" + + , inputs ["//Evac_thr.c", "//Scav_thr.c"] ? + pure ["-DPARALLEL_GC", "-Irts/sm"] + + , input "//StgCRun.c" ? windowsHost ? arg "-Wno-return-local-addr" + , input "//RetainerProfile.c" ? flag GccIsClang ? + arg "-Wno-incompatible-pointer-types" + , inputs [ "//Interpreter.c", "//Storage.c", "//Adjustor.c" ] ? + arg "-Wno-strict-prototypes" + , windowsHost ? arg ("-DWINVER=" ++ windowsVersion) ] + mconcat + [ 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 ? + input "//package.conf.in" ? + output "//package.conf.install.raw" ? + pure [ "-DINSTALLING" + , "-DLIB_DIR=\"" ++ destDir ++ ghclibDir ++ "\"" + , "-DINCLUDE_DIR=\"" ++ destDir ++ ghclibDir -/- "include\"" ] + + , builder HsCpp ? flag HaveLibMingwEx ? arg "-DHAVE_LIBMINGWEX" ] + +-- See @rts/ghc.mk@. +rtsWarnings :: Args +rtsWarnings = mconcat + [ pure ["-Wall", "-Werror"] + , flag GccLt34 ? arg "-W", not <$> flag GccLt34 ? 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" + , not <$> flag GccLt46 ? arg "-Wundef" + , arg "-fno-strict-aliasing" ] diff --git a/hadrian/src/Settings/Packages/RunGhc.hs b/hadrian/src/Settings/Packages/RunGhc.hs new file mode 100644 index 0000000000..03a19c8373 --- /dev/null +++ b/hadrian/src/Settings/Packages/RunGhc.hs @@ -0,0 +1,9 @@ +module Settings.Packages.RunGhc (runGhcPackageArgs) where + +import Oracles.Setting +import Expression + +runGhcPackageArgs :: Args +runGhcPackageArgs = package runGhc ? builder Ghc ? input "//Main.hs" ? do + version <- getSetting ProjectVersion + pure ["-cpp", "-DVERSION=" ++ show version] diff --git a/hadrian/src/Settings/Warnings.hs b/hadrian/src/Settings/Warnings.hs new file mode 100644 index 0000000000..f8eb4a5da0 --- /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 Settings + +-- See @mk/warnings.mk@ for warning-related arguments in the Make build system. + +-- | Default Haskell warning-related arguments. +defaultGhcWarningsArgs :: Args +defaultGhcWarningsArgs = mconcat + [ notStage0 ? pure [ "-Werror", "-Wnoncanonical-monad-instances" ] + , (not <$> flag GccIsClang) ? mconcat + [ (not <$> flag GccLt46) ? + (not <$> windowsHost ) ? arg "-optc-Werror=unused-but-set-variable" + , (not <$> flag GccLt44) ? 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..1b7c3f8bdd --- /dev/null +++ b/hadrian/src/UserSettings.hs @@ -0,0 +1,64 @@ +-- 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 ( + userBuildRoot, userFlavours, userPackages, verboseCommand, + buildProgressColour, successColour, stage1Only + ) where + +import Hadrian.Utilities +import System.Console.ANSI + +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. + +-- | All build results are put into the 'buildRoot' directory. +userBuildRoot :: BuildRoot +userBuildRoot = BuildRoot "_build" + +-- | 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 = BuildProgressColour (Dull, Magenta) + +-- | Set colour for success messages (e.g. a package is built successfully). +successColour :: SuccessColour +successColour = SuccessColour (Dull, Green) + +-- TODO: Set this flag from the command line. +-- | Set this flag to 'True' to disable building Stage2 GHC (i.e. the @ghc-stage2@ +-- executable) and Stage2 utilities (such as @haddock@). Note that all Stage0 +-- and Stage1 libraries (including 'compiler') will still be built. Enabling +-- this flag during installation leads to installing @ghc-stage1@ instead of +-- @ghc-stage2@, and @ghc-pkg@ that was build with the Stage0 compiler. +-- 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..3c61daecfd --- /dev/null +++ b/hadrian/src/Utilities.hs @@ -0,0 +1,80 @@ +module Utilities ( + build, buildWithResources, buildWithCmdOptions, runBuilder, runBuilderWith, + needLibrary, contextDependencies, stage1Dependencies, libraryTargets, + topsortPackages + ) where + +import qualified Hadrian.Builder as H +import Hadrian.Haskell.Cabal +import Hadrian.Utilities + +import Context +import Expression hiding (stage) +import Oracles.PackageData +import Settings +import Target +import UserSettings + +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 + +-- | Given a 'Context' this 'Action' look up the package dependencies and wrap +-- 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 scan package @.cabal@ files, see 'pkgDependencies' defined +-- in "Hadrian.Haskell.Cabal". +contextDependencies :: Context -> Action [Context] +contextDependencies Context {..} = case pkgCabalFile package of + Nothing -> return [] -- Non-Cabal packages have no dependencies. + Just cabalFile -> do + let depStage = min stage Stage1 + depContext = \pkg -> Context depStage pkg way + deps <- pkgDependencies cabalFile + pkgs <- sort <$> stagePackages depStage + return . map depContext $ intersectOrd (compare . pkgName) pkgs deps + +-- | 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 + confFile <- pkgConfFile context + libFile <- pkgLibraryFile context + lib0File <- pkgLibraryFile0 context + lib0 <- buildDll0 context + ghciLib <- pkgGhciLibraryFile context + ghciFlag <- if includeGhciLib + then interpretInContext context $ getPkgData BuildGhciLib + else return "NO" + let ghci = ghciFlag == "YES" && (stage context == Stage1 || stage1Only) + return $ [ confFile, libFile ] ++ [ lib0File | lib0 ] ++ [ 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..e904d93cbc --- /dev/null +++ b/hadrian/src/Way.hs @@ -0,0 +1,162 @@ +module Way ( + WayUnit (..), Way, wayUnit, 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 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 + +-- | 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 [(vanilla, "")] 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 + +-- | 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/stack.yaml b/hadrian/stack.yaml new file mode 100644 index 0000000000..da037630ab --- /dev/null +++ b/hadrian/stack.yaml @@ -0,0 +1,22 @@ +# 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-9.0 + +# Local packages, usually specified by relative directory name +packages: +- '.' +- '../libraries/Cabal/Cabal' + +extra-deps: +- shake-0.16 + +nix: + enable: false + packages: + - autoconf + - automake + - gcc + - git + - ncurses + - perl |