diff options
| author | simonpj <unknown> | 1997-03-14 08:11:17 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 1997-03-14 08:11:17 +0000 |
| commit | 1fb1ab5d53a09607e7f6d2450806760688396387 (patch) | |
| tree | b437d55fe6dc77a4bb21143be31188b9985793f9 | |
| parent | fa6fb09e2e4e6918eebc79ed187f32c88817c9db (diff) | |
| download | haskell-1fb1ab5d53a09607e7f6d2450806760688396387.tar.gz | |
[project @ 1997-03-14 07:52:06 by simonpj]
Major update to more-or-less 2.02
319 files changed, 14097 insertions, 25084 deletions
diff --git a/ANNOUNCE-2.02 b/ANNOUNCE-2.02 new file mode 100644 index 0000000000..38b6b5b3ab --- /dev/null +++ b/ANNOUNCE-2.02 @@ -0,0 +1,177 @@ + The Glasgow Haskell Compiler -- version 2.02 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We are pleased to announce the first release of the Glasgow Haskell +Compiler (GHC, version 2.02) for *Haskell 1.4*. Sources and binaries +are freely available by anonymous FTP and on the World-Wide Web; +details below. + +Haskell is "the" standard lazy functional programming language; the +current language version is 1.3, agreed in May, 1996. The Haskell +Report is online at + + http://haskell.cs.yale.edu/1.4/haskell-report.html + +GHC 2.02 is a beta-quality release: + + * It is reliable. + It has been extensively tested against a large suite of Haskell 1.2 + programs, but not so extensively tested against Haskell 1.4 programs + because we don't have a comprehensive set (Donations of Haskell 1.4 + programs to our test suite are most welcome). + + * It should generate good code. + All the optimisations that GHC 0.29 used to do are back in, with + the exception of specialisation. It ought to be the case that + GHC 2.02 outperforms GHC 0.29, because it has a much better + handle on cross-module inlining, but there's a good chance that + there are performance "holes" lurking. We have yet to make + a systematic comparison. (Please send us programs where 2.02 + does noticeably worse than 0.29.) + + * It is more expensive than it should be. + GHC 2.02 has received even less attention to its own performance. + At present it eats more space and time than GHC 0.29, especially + for very small programs. We'll work on this. + + * A couple of Haskell 1.4 features are incompletely supported, + notably polymorphic strictness annotations, and Unicode. + +If you want to use Haskell 1.4, this is a good moment to switch. If +you don't need the Haskell 1.4 extensions, then stay with GHC 0.29. +If you want to hack on GHC itself, then 2.02 is definitely for you. +The release notes comment further on this point. + +GHC 2.02 is substantially changed from 2.01. Changes worth noting +include: + + * The whole front end, which deals with the module system, has + been rewritten. The interface file format has changed. + + * GHC 2.02 comes complete with Green Card, a C foreign language + interface for GHC. Green card is a pre-processor that + scans Haskell source files for Green Card directives, which + it expands into tons of "ccall" boilerplate that marshalls + your arguments to and from C. + + * GHC 2.02 is available for Windows NT. From now on, Windows NT + will be a fully supported platform for GHC. + + * GHC 2.02 supports full cross moudule inlining. Unlike 0.29 and + its predecessors, inlining can happen even if the inlined body + mentions a function or type that is not itself exported. This is + one place Haskell 1.4's new module system really pays off. + + * Like 2.01, GHC 2.02 aborts a compilation if it decides that + nothing that the module imports *and acually uses* has changed. + This decision is now taken by the compiler itself, rather than + by a Perl script (as in 2.01) which sometimes got it wrong. + + * The ghc/lib libraries are much more systematically organised. + + * There's a completely new "make" system. This will mainly affect people + who want the source distribution, who will hopefully find it much, much, + easier than grappling with the old Jmakefiles. Even for binary + installation, the procedure is a little simpler, though. + +Please see the release notes for a complete discussion of What's New. + +To run this release, you need a machine with 16+MB memory (more if +building from sources), GNU C (`gcc'), and `perl'. We have seen GHC +2.01 work on these platforms: alpha-dec-osf2, hppa1.1-hp-hpux9, +sparc-sun-{sunos4,solaris2}, mips-sgi-irix5, and +i386-unknown-{linux,solaris2,freebsd}. Similar platforms should work +with minimal hacking effort. The installer's guide give a full +what-ports-work report. + +Binaries are distributed in `bundles', e.g. a "profiling bundle" or a +"concurrency bundle" for your platform. Just grab the ones you need. + +Once you have the distribution, please follow the pointers in +ghc/README to find all of the documentation about this release. NB: +preserve modification times when un-tarring the files (no `m' option +for tar, please)! + +We run mailing lists for GHC users and bug reports; to subscribe, send +mail to majordomo@dcs.gla.ac.uk; the msg body should be: + + subscribe glasgow-haskell-<which> Your Name <your-email@where.you.are> + +Please send bug reports about GHC to glasgow-haskell-bugs@dcs.gla.ac.uk. + +Simon Peyton Jones + +Dated: February 1997 + +Relevant URLs on the World-Wide Web: + +GHC home page http://www.dcs.gla.ac.uk/fp/software/ghc/ +Glasgow FP group page http://www.dcs.gla.ac.uk/fp/ +comp.lang.functional FAQ http://www.cs.nott.ac.uk/Department/Staff/mpj/faq.html + +====================================================================== +How to get GHC 2.01: + +This release is available by anonymous FTP from the main Haskell +archive sites, in the directory pub/haskell/glasgow: + + ftp.dcs.gla.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.227.140) + haskell.cs.yale.edu (128.36.11.43) + +The Glasgow site is mirrored by src.doc.ic.ac.uk (146.169.43.1), in +computing/programming/languages/haskell/glasgow. + +These are the available files (.gz files are gzipped) -- some are `on +demand', ask if you don't see them: + +ghc-2.01-src.tar.gz The source distribution; about 3MB. + +ghc-2.01.ANNOUNCE This file. + +ghc-2.01.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-2.01-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +ghc-2.01-<platform>.tar.gz Basic binary distribution for a particular + <platform>. Unpack and go: you can compile + and run Haskell programs with nothing but one + of these files. NB: does *not* include + profiling (see below). + + <platform> ==> alpha-dec-osf2 + hppa1.1-hp-hpux9 + i386-unknown-freebsd + i386-unknown-linux + i386-unknown-solaris2 + m68k-sun-sunos4 + mips-sgi-irix5 + sparc-sun-sunos4 + sparc-sun-solaris2 + +ghc-2.01-<bundle>-<platform>.tar.gz + + <platform> ==> as above + <bundle> ==> prof (profiling) + conc (concurrent Haskell) + par (parallel) + gran (GranSim parallel simulator) + ticky (`ticky-ticky' counts -- for implementors) + prof-conc (profiling for "conc[urrent]") + prof-ticky (ticky for "conc[urrent]") + +ghc-2.01-hc-files.tar.gz Basic set of intermediate C (.hc) files for the + compiler proper, the prelude, and `Hello, + world'. Used for bootstrapping the system. + About 4MB. + +ghc-2.01-<bundle>-hc-files.tar.gz Further sets of .hc files, for + building other "bundles", e.g., profiling. + +ghc-2.01-hi-files-<blah>.tar.gz Sometimes it's more convenient to + use a different set of interface files than + the ones in *-src.tar.gz. (The installation + guide will advise you of this.) @@ -1,23 +1,92 @@ -#----------------------------------------------------------------------------- -# $Id: Makefile,v 1.2 1996/11/21 16:45:54 simonm Exp $ +################################################################################# +# +# fptools/Makefile +# +# This is the main Makefile for fptools. +# +################################################################################# -TOP = . -SUBDIRS = glafp-utils ghc -include $(TOP)/mk/gen.mk -include $(TOP)/mk/subdir.mk +TOP=. +include $(TOP)/mk/boilerplate.mk +SRC_DIST_DIR=$(shell pwd)/$(SRC_DIST_NAME) -line = @echo "------------------------------------------------------------------------------" +SUBDIRS = $(ProjectsToBuild) -boot :: - @echo "Bootstrapping $(PROJECTNAME)..." - $(line) - @echo "Booting glafp-utils" - $(line) - @$(MAKE) -C glafp-utils boot +# +# Files to include in fptools source distribution +# +SRC_DIST_DIRS += mk $(ProjectsToBuild) +SRC_DIST_FILES += configure.in config.guess config.sub configure README ANNOUNCE NEWS INSTALL Makefile - $(line) - @echo "Booting ghc" - $(line) - @$(MAKE) -C ghc boot - @echo "Done!" +# +# Making a binary distribution +# +BIN_DIST_TMPDIR=$(shell pwd) +BIN_DIST_NAME=fptools + +# +# list of toplevel `projects' to include in binary distrib. +# +BIN_DIST_DIRS=ghc + +binary-dist:: binary-dist-pre + +BIN_DIST_TOP= distrib/Makefile-bin.in \ + distrib/configure-bin.in \ + distrib/README \ + distrib/INSTALL \ + distrib/ANNOUNCE + +binary-dist:: + @for i in $(BIN_DIST_TOP); do \ + @echo cp $$i $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) \ + cp $$i $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) \ + done; + +# +# Creating and copying the documentation into the bin-dist tree. +# +binary-dist:: + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/html + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/dvi + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/info + @echo "Making html documentation.." + $(MAKE) -C docs --no-print-directory $(MFLAGS) html + cp docs/html/* $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/html + @echo "Making dvi files.." + $(MAKE) -C docs --no-print-directory $(MFLAGS) dvi + cp docs/*.dvi $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/dvi + @echo "Making info files.." + $(MAKE) -C docs --no-print-directory $(MFLAGS) info + cp docs/*.info* $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/info + +dist :: dist-pre +include $(TOP)/mk/target.mk +dist :: dist-post + +# +# Automatically remake update configuration files +# (from autoconf manual) +# +configure: configure.in + autoconf +# +# autoheader might not change config.h.in, so touch a stamp file. +# +mk/config.h.in: mk/stamp-h.in +mk/stamp-h.in: configure.in + autoheader + echo timestamp > mk/stamp-h.in + +mk/config.h: mk/stamp-h +mk/stamp-h: mk/config.h.in config.status + ./config.status + +config.status: configure + ./config.status --recheck + +.PHONY: config + +config: config.status + @: diff --git a/configure.in b/configure.in index 94624cac42..12ed4cf11f 100644 --- a/configure.in +++ b/configure.in @@ -4,7 +4,7 @@ dnl dnl * INITIAL SETUP, CHOICE OF PLATFORM(S) #!/bin/sh # -# (c) The AQUA Project, Glasgow University, 1994-1995 +# (c) The AQUA Project, Glasgow University, 1994-1997 # # Configure script for the Glasgow functional programming tools # (created automagically by autoconf...do not edit by hand) @@ -12,163 +12,51 @@ dnl * INITIAL SETUP, CHOICE OF PLATFORM(S) # Do "./configure --help" to see what flags are available. # (Better yet, read the documentation!) # -AC_INIT(mk/platform.mk.in) +# First off, a distrib sanity check.. +AC_INIT(mk/config.mk.in) # ------------------------------------------------------------------------- # Prepare to generate the following header files # -AC_CONFIG_HEADER(ghc/includes/config.h literate/lit-deatify/config.h) +# +AC_CONFIG_HEADER(mk/config.h) # No, we don't do `--srcdir'... if test x"$srcdir" != 'x.' ; then - echo "This configuration does not support the \`--srcdir' option." + echo "This configuration does not support the \`--srcdir' option.." exit 1 fi +# +# Remove some automounter nonsense (Glasgow specific gruff) +# hardtop=`pwd` -hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/export/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` +hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` + +#OLD: hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/export/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` + echo '' echo "*** The top of your build tree is: $hardtop" AC_SUBST(hardtop) # ------------------------------------------------------------------------- -dnl ** choose what blobs to build (ghc,hslibs,haggis,happy,nofib,????) - -# set to the name for the dir if doing it, otherwise empty -DoingHsLibs='' -DoingNoFib='' -DoingHappy='' -DoingHaggis='' -MkWorldSetup='std' - -AC_ARG_ENABLE(hslibs, - [ -********************************************************************** -* Configuration options for the Glasgow functional-programming tools * -********************************************************************** - -First, select *which* of the tools you want to build, with ---{enable,disable}-{hslibs,nofib,happy,haggis}. (Currently, you have to -build ghc.) - -Second, you may set one of a few applies-in-all-cases options. For -example, --with-tmpdir=/usr/tmp. - -Then you may set various options which are specifically for the tools you -choose in step 1. For GHC, perhaps --enable-concurrent. For NoFib, -perhaps --enable-all-tests. And so on. - -The rest of this message lists all of the configure options. If the option -is enabled by default, the message says how to disable it. And vice versa. - -If you are confused, don't forget the installation documents that came with -the software! - -******************************************************************* -** FOR SELECTING WHICH GLASGOW FP TOOLS TO BUILD:] - [--enable-hslibs build suite of Haskell libraries], - [case "$enableval" in - yes) DoingHsLibs='hslibs' - ;; - no) DoingHsLibs='' - ;; - *) echo "I don't understand this option: --enable-hslibs=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingHsLibs" = 'xxxhslibs' -a \( ! -d hslibs \) ; then - DoingHsLibs='' - echo 'Doing --disable-hslibs, as there is no hslibs directory' -fi - -AC_ARG_ENABLE(nofib, - [--enable-nofib build NoFib suite as part of Glasgow FP tools], - [case "$enableval" in - yes) DoingNoFib='nofib' - ;; - no) DoingNoFib='' - ;; - *) echo "I don't understand this option: --enable-nofib=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingNoFib" = 'xxxnofib' -a \( ! -d nofib \) ; then - DoingNoFib='' - echo 'Doing --disable-nofib, as there is no nofib directory' -fi - -AC_ARG_ENABLE(happy, - [--enable-happy build Happy parser-generator as part of Glasgow FP tools], - [case "$enableval" in - yes) DoingHappy='happy' - ;; - no) DoingHappy='' - ;; - *) echo "I don't understand this option: --enable-happy=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingHappy" = 'xxxhappy' -a \( ! -d happy \) ; then - DoingHappy='' - echo 'Doing --disable-happy, as there is no happy directory' -fi - -AC_ARG_ENABLE(haggis, - [--enable-haggis build Haggis GUI toolkit as part of Glasgow FP tools], - [case "$enableval" in - yes) DoingHaggis='haggis' - ;; - no) DoingHaggis='' - ;; - *) echo "I don't understand this option: --enable-haggis=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingHaggis" = 'xxxhaggis' -a \( ! -d haggis \) ; then - DoingHaggis='' - echo 'Doing --disable-haggis, as there is no haggis directory' -fi - -AC_SUBST(DoingHsLibs) -AC_SUBST(DoingNoFib) -AC_SUBST(DoingHappy) -AC_SUBST(DoingHaggis) - -# ------------------------------------------------------------------------- dnl ** choose host(/target/build) platform +# # Guess host/target/build platform(s) if necessary. -# Partly stolen from GCC "configure". # -if test "x$target" = xNONE ; then - if test "x$nonopt" != xNONE ; then - target=$nonopt - else - # This way of testing the result of a command substitution is - # defined by Posix.2 (section 3.9.1) as well as traditional shells. - if target=`$srcdir/config.guess` ; then - echo "Configuring for a ${target} host." 1>&2 - else - echo 'Config.guess failed to determine the host type. You need \ -to specify one.' 1>&2 - if test -r config.status ; then - tail +2 config.status 1>&2 - fi - exit 1 - fi - fi -fi +AC_CANONICAL_SYSTEM # "$host" defaults to "$target" if test "x$host" = xNONE ; then host=$target fi # "$build" defaults to "$host" -if test "x$build" = xNONE ; then - build=$host -else - echo "This configuration does not support the \`--build' option." - exit 1 -fi +#if test "x$build" = xNONE ; then +# build=$host +#else +# echo "This configuration does not support the \`--build' option." +# exit 1 +#fi dnl ** canonicalize platform names # Canonicali[sz]e those babies @@ -181,22 +69,23 @@ if test x"$TargetPlatform" != x"$HostPlatform" ; then exit 1 fi +# # The following will be more difficult when we *are* cross-compiling. # Suitable names to slam in *_CPP are in platform.h.in. # We also record the architecture, vendor, and operating system (OS) # separately. case $HostPlatform in alpha-dec-osf[[1234]]*) - HostPlatform=alpha-dec-osf1 # canonicalise for our purposes + HostPlatform=alpha-dec-osf1 # canonicalise for our purposes TargetPlatform=alpha-dec-osf1 # this will work for now... (hack) - BuildPlatform=alpha-dec-osf1 #hack + BuildPlatform=alpha-dec-osf1 # hack HostPlatform_CPP='alpha_dec_osf1' HostArch_CPP='alpha' HostVendor_CPP='dec' HostOS_CPP='osf1' ;; hppa1.1-hp-hpux*) - HostPlatform=hppa1.1-hp-hpux # canonicalise for our purposes (hack) + HostPlatform=hppa1.1-hp-hpux # canonicalise for our purposes (hack) TargetPlatform=hppa1.1-hp-hpux BuildPlatform=hppa1.1-hp-hpux HostPlatform_CPP='hppa1_1_hp_hpux' @@ -205,7 +94,7 @@ hppa1.1-hp-hpux*) HostOS_CPP='hpux' ;; i[[3456]]86-*-linuxaout*) - HostPlatform=i386-unknown-linuxaout # hack again + HostPlatform=i386-unknown-linuxaout # hack again TargetPlatform=i386-unknown-linuxaout BuildPlatform=i386-unknown-linuxaout HostPlatform_CPP='i386_unknown_linuxaout' @@ -249,6 +138,15 @@ i[[3456]]86-*-solaris2*) HostVendor_CPP='unknown' HostOS_CPP='solaris2' ;; +i[[3456]]86-*-cygwin32*) + HostPlatform=i386-unknown-cygwin32 # hack again + TargetPlatform=i386-unknown-cygwin32 + BuildPlatform=i386-unknown-cygwin32 + HostPlatform_CPP='i386_unknown_cygwin32' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='cygwin32' + ;; m68k-next-nextstep2) HostPlatform_CPP='m68k_next_nextstep2' HostArch_CPP='m68k' @@ -326,12 +224,9 @@ sparc-sun-solaris2*) exit 1 ;; esac - -test -n "$verbose" && echo "Host platform set to $HostPlatform" -test -n "$verbose" -a x"$HostPlatform" != x"$TargetPlatform" \ - && echo "Target platform set to $TargetPlatform" -test -n "$verbose" -a x"$BuildPlatform" != x"$HostPlatform" \ - && echo "Build platform set to $BuildPlatform" +echo "Which we'll canonicalise into: $HostPlatform" +test x"$HostPlatform" != x"$TargetPlatform" && echo "Target platform set to $TargetPlatform" +test x"$BuildPlatform" != x"$HostPlatform" && echo "Build platform set to $BuildPlatform" BuildPlatform_CPP=$HostPlatform_CPP TargetPlatform_CPP=$HostPlatform_CPP @@ -341,10 +236,11 @@ BuildOS_CPP=$HostOS_CPP TargetOS_CPP=$HostOS_CPP BuildVendor_CPP=$HostVendor_CPP TargetVendor_CPP=$HostVendor_CPP -dnl Cannot afford all these AC_SUBSTs (because of braindead seds w/ 99 cmd limits + +dnl Cannot afford all these SUBSTs (because of braindead seds w/ 99 cmd limits) dnl AC_SUBST(BuildPlatform) AC_SUBST(HostPlatform) -dnl AC_SUBST(TargetPlatform) +AC_SUBST(TargetPlatform) AC_SUBST(HostPlatform_CPP) dnl AC_SUBST(BuildPlatform_CPP) dnl AC_SUBST(TargetPlatform_CPP) @@ -364,6 +260,8 @@ dnl * _GENERAL_ CONFIGURATION CHECKS # dnl ** are we at Glasgow? # +# This stuff is in danger of going away.. +# if test -d /local/fp -a -d /users/fp/simonpj; then echo "Brilliant! You must be a Glaswegian." AT_GLASGOW=1 @@ -471,7 +369,8 @@ else rm -fr conftest* fi AC_SUBST(HaveGcc) -AC_C_CROSS + +# Deprecated (AC_PROG_CC does it): AC_C_CROSS # dnl ** figure out how to do context diffs # (NB: NeXTStep thinks diff'ing a file against itself is "trouble") @@ -507,7 +406,7 @@ if test -z "$YaccCmd"; then $WhatCmd $YaccCmd > conftest.out if egrep 'y1\.c 1\..*SMI' conftest.out >/dev/null 2>&1; then echo "I don't trust your $YaccCmd; it looks like an old Sun yacc" - if test -x /usr/lang/yacc; then + if test -f /usr/lang/yacc; then echo "I'm going to use /usr/lang/yacc instead" YaccCmd=/usr/lang/yacc else @@ -529,146 +428,6 @@ dnl ** Find lex command (lex or flex) and library (-ll or -lfl) # AC_PROG_LEX -#-------------------------------------------------------------- -WithHc='haskell-compiler-unspecified' -WithHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc, - [ -******************************************************************* -** GENERAL OPTIONS WHICH APPLY TO ALL TOOLS: - ---with-hc=<Haskell compiler> - ghc* => Glasgow Haskell invoked by the name given - hbc* => Chalmers HBC, invoked by the name given - nhc* => Niklas Rojemo's "nhc", invoked by the name given - C or c => Don't use a Haskell compiler; - build from intermediate C (.hc) files. - in-place => Use ghc/driver/ghc; i.e. you've built GHC - and you want to use it un-installed ("in-place"). - ], - [case "$withval" in - ghc* | glhc* ) - WithHc=$withval - ;; - hbc* ) WithHc=$withval - ;; - nhc* ) WithHc=$withval - ;; - c | C) WithHc='C' - ;; - in-place ) - WithHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHcType -case $WithHc in - haskell-compiler-unspecified ) # maybe they will say something later... - ;; - ghc* | glhc* ) - WithHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc,$WithHc,$ac_dir/$ac_word) - if test -z "$have_ghc"; then - echo "Can't find Glasgow Haskell to compile with: $WithHc" - exit 1 - fi - ;; - hbc* ) # Look for the dastardly competition - WithHcType='HC_CHALMERS_HBC' - AC_CHECK_PROG(have_hbc,$WithHc,YES,NO) - if test $have_hbc = 'NO' ; then - echo "Can't find Chalmers HBC to compile with: $WithHc" - exit 1 - fi - ;; - nhc* ) # Look for Niklas Rojemo's "nhc" - WithHcType='HC_ROJEMO_NHC' - AC_CHECK_PROG(have_nhc,$WithHc,YES,NO) - if test $have_nhc = 'NO' ; then - echo "Can't find Niklas Rojemo's NHC to compile with: $WithHc" - exit 1 - fi - ;; - c | C) WithHcType='HC_USE_HC_FILES' - ;; - IN-PLACE) WithHcType='HC_GLASGOW_GHC' - WithHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHc) -AC_SUBST(WithHcType) - -dnl ** Possibly use something else instead of 'gcc'. -WhatGccIsCalled=gcc -AC_ARG_WITH(gcc, - [--with-gcc=<gcc command> - Use a different command instead of 'gcc' for the GNU C compiler.], - [HaveGcc=YES; WhatGccIsCalled="$withval"]) -AC_SUBST(WhatGccIsCalled) - -dnl ** Choose which make to use (default 'make') -MakeCmd='make' -AC_ARG_WITH(make, - [ ---with-make=<make command> - Use an alternate command instead of 'make'. This is useful - when GNU make is required (for instance when the default make - supplied by the system won't work, as is the case on FreeBSD - and NetBSD).], - [MakeCmd="$withval"]) -AC_SUBST(MakeCmd) - -dnl ** possibly choose a different tmpdir (default /tmp) -# let the user decide where the best tmpdir is -# /tmp is the default; /usr/tmp is sometimes a good choice. -# Very site-specific. -TmpDir='/tmp' -AC_ARG_WITH(tmpdir, - [ ---with-tmpdir=<temp directory> - Use an alternative directory for temporary files (presumably - because /tmp is too small).], - [TmpDir="$withval"]) -AC_SUBST(TmpDir) - -dnl ** possibly set a max heap for Haskell compilations -HcMaxHeapFlag='' -AC_ARG_WITH(max-heap, - [ ---with-max-heap=<heap size, e.g., 32m> - Do all Haskell compilations with a heap of this size.], - [HcMaxHeapFlag="-H$withval"]) -AC_SUBST(HcMaxHeapFlag) - -dnl ** possibly set a max stack for Haskell compilations -HcMaxStackFlag='' -AC_ARG_WITH(max-stack, - [ ---with-max-stack=<stack size, e.g., 4m> - Do all Haskell compilations with a stack of this size.], - [HcMaxStackFlag="-K$withval"]) -AC_SUBST(HcMaxStackFlag) - -dnl ** figure out about mkdependHS -MkDependHSCmd='mkdependHS' -if test -f ./ghc/utils/mkdependHS/mkdependHS \ - -o -f ./ghc/utils/mkdependHS/mkdependHS.prl ; then - MkDependHSCmd='TopDirPwd/ghc/utils/mkdependHS/mkdependHS' -fi -AC_ARG_WITH(mkdependHS, - [--with-mkdependHS=<mkdependHS command> - Use a different command instead of 'mkdependHS'.], - [MkDependHSCmd="$withval"]) -dnl AC_CHECK_PROG(have_mkdependHS,$MkDependHSCmd,YES,NO) -dnl if test $have_mkdependHS = 'NO' ; then -dnl MkDependHSCmd=':' -dnl fi -AC_SUBST(MkDependHSCmd) - # ------------------------------------------------------------------------- # dnl ** figure out how to invoke cpp directly (gcc -E is no good) @@ -744,6 +503,59 @@ if test -n "$NeedRanLib"; then fi AC_SUBST(RANLIB) # +# +dnl ** Check to see whether ln -s works +# +AC_PROG_LN_S() +AC_SUBST(LN_S) +# +dnl ** Find the path to sed ** +AC_PATH_PROG(SedCmd,sed,$ac_dir/$ac_word) +# +# It better be around somewhere (we wouldn't +# exec this script properly if it wasn't!) +# +AC_SUBST(SedCmd) +# +dnl ** check for time command ** +AC_PATH_PROG(TimeCmd,time,$ac_dir/$ac_word) +# +AC_SUBST(TimeCmd) +# +dnl ** check for tar ** +# +# if GNU tar is named gtar, look for it first. +# +AC_PATH_PROGS(TarCmd,gtar tar,tar) +AC_SUBST(TarCmd) + +# +dnl ** check for gzip/compress ** +AC_PATH_PROGS(CompressCmd,gzip compress,gzip) + +compress_nm=`basename $CompressCmd` + +if test x"$compress_nm" = xgzip; then + CompressCmd="$CompressCmd -d" + CompressSuffix="gz" +else + CompressSuffix="Z" +fi +AC_SUBST(CompressCmd) +AC_SUBST(CompressSuffix) +# +dnl ** check for installed happy binary +# +AC_PATH_PROG(HappyCmd,happy) +AC_SUBST(HappyCmd) +# +# +dnl ** check for installed lx binary +# +AC_PATH_PROG(LxCmd,lx) +AC_SUBST(LxCmd) +# +# dnl ** check for full ANSI header (.h) files # AC_HEADER_STDC @@ -797,1137 +609,26 @@ char **argv; exit(1); }], LeadingUnderscore='YES', LeadingUnderscore='NO', LeadingUnderscore='YES') test -n "$verbose" && echo " setting LeadingUnderscore to $LeadingUnderscore" +AC_SUBST(LeadingUnderscore) -dnl ------------------------------------------------------- -dnl ** which builds to build? -dnl ** (applies to anything w/ libraries (ghc, hslibs, ???) -dnl ------------------------------------------------------- -# builds: normal = sequential _ap_o ; _p = profiling (sequential); -# _t = ticky; _u = unregisterized -Build_normal='YES' -Build_p='YES' -Build_t='NO' -Build_u='NO' -# _mc = concurrent; _mr = profiled concurrent; _mt = ticky concurrent -# _mp = parallel; _mg = gransim -Build_mc='NO' -Build_mr='NO' -Build_mt='NO' -Build_mp='NO' -Build_mg='NO' -# GC builds: _2s, _1s, _du (, _gn) -Build_2s='NO' -Build_1s='NO' -Build_du='NO' -# user builds: a...o -Build_a='NO' -Build_b='NO' -Build_c='NO' -Build_d='NO' -Build_e='NO' -Build_f='NO' -Build_g='NO' -Build_h='NO' -Build_i='NO' -Build_j='NO' -Build_k='NO' -Build_l='NO' -Build_m='NO' -Build_n='NO' -Build_o='NO' -Build_A='NO' -Build_B='NO' -# More could be added here... - -AC_ARG_ENABLE(normal-build, - [ -******************************************************************* -** \`GHC' (GLASGOW HASKELL COMPILER) OPTIONS: - -Choose all the \`builds' of GHC that you want: - ---disable-normal-build do *not* build GHC for normal sequential code], - [case "$enableval" in - yes) Build_normal='YES' - ;; - no) Build_normal='NO' - ;; - *) echo "I don't understand this option: --enable-normal-build=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(profiling, - [--disable-profiling do *not* build profiling features], - [case "$enableval" in - yes) Build_p='YES' - ;; - no) Build_p='NO' - ;; - *) echo "I don't understand this option: --enable-profiling=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(ticky, - [--enable-ticky build for \`ticky-ticky' profiling (for implementors)], - [case "$enableval" in - yes) Build_t='YES' - ;; - no) Build_t='NO' - ;; - *) echo "I don't understand this option: --enable-ticky=$enableval" - exit 1 - ;; - esac]) +AC_OUTPUT(mk/config.mk, echo timestamp > mk/stamp-h ) -AC_ARG_ENABLE(concurrent, - [--enable-concurrent turn on \`concurrent Haskell' features], - [case "$enableval" in - yes) Build_mc='YES' - ;; - no) Build_mc='NO' - ;; - *) echo "I don't understand this option: --enable-concurrent=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(profiled-concurrent, - [--enable-profiled-concurrent turn on profiling for \`concurrent Haskell'], - [case "$enableval" in - yes) Build_mr='YES' - ;; - no) Build_mr='NO' - ;; - *) echo "I don't understand this option: --enable-profiled-concurrent=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(ticky-concurrent, - [--enable-ticky-concurrent turn on \`ticky-ticky' profiling for \`concurrent Haskell'], - [case "$enableval" in - yes) Build_mt='YES' - ;; - no) Build_mt='NO' - ;; - *) echo "I don't understand this option: --enable-ticky-concurrent=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(parallel, - [--enable-parallel turn on \`parallel Haskell' features], - [case "$enableval" in - yes) Build_mp='YES'; - ;; - no) Build_mp='NO' - ;; - *) echo "I don't understand this option: --enable-parallel=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gransim, - [--enable-gransim turn on GranSim parallel simulator], - [case "$enableval" in - yes) Build_mg='YES'; - ;; - no) Build_mg='NO' - ;; - *) echo "I don't understand this option: --enable-gransim=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gc-2s, - [--enable-gc-2s a build with the 2-space copying garbage collector], - [case "$enableval" in - yes) Build_2s='YES' - ;; - no) Build_2s='NO' - ;; - *) echo "I don't understand this option: --enable-gc-2s=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gc-1s, - [--enable-gc-1s a build with the 1-space compacting garbage collector], - [case "$enableval" in - yes) Build_1s='YES' - ;; - no) Build_1s='NO' - ;; - *) echo "I don't understand this option: --enable-gc-1s=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gc-du, - [--enable-gc-du a build with \`dual-mode' (1s/2s) garbage collector], - [case "$enableval" in - yes) Build_du='YES' - ;; - no) Build_du='NO' - ;; - *) echo "I don't understand this option: --enable-gc-du=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-a, - [--enable-user-way-a build for \`user way a' (mostly for implementors)], - [case "$enableval" in - yes) Build_a='YES' - ;; - no) Build_a='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-a=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-b, - [--enable-user-way-b build for \`user way b' (mostly for implementors)], - [case "$enableval" in - yes) Build_b='YES' - ;; - no) Build_b='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-b=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-c, - [--enable-user-way-c build for \`user way c' (mostly for implementors)], - [case "$enableval" in - yes) Build_c='YES' - ;; - no) Build_c='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-c=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-d, - [--enable-user-way-d build for \`user way d' (mostly for implementors)], - [case "$enableval" in - yes) Build_d='YES' - ;; - no) Build_d='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-d=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-e, - [--enable-user-way-e build for \`user way e' (mostly for implementors)], - [case "$enableval" in - yes) Build_e='YES' - ;; - no) Build_e='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-e=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-f, - [--enable-user-way-f build for \`user way f' (mostly for implementors)], - [case "$enableval" in - yes) Build_f='YES' - ;; - no) Build_f='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-f=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-g, - [--enable-user-way-g build for \`user way g' (mostly for implementors)], - [case "$enableval" in - yes) Build_g='YES' - ;; - no) Build_g='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-g=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-h, - [--enable-user-way-h build for \`user way h' (mostly for implementors)], - [case "$enableval" in - yes) Build_h='YES' - ;; - no) Build_h='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-h=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-i, - [--enable-user-way-i build for \`user way i' (mostly for implementors)], - [case "$enableval" in - yes) Build_i='YES' - ;; - no) Build_i='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-i=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-j, - [--enable-user-way-j build for \`user way j' (mostly for implementors)], - [case "$enableval" in - yes) Build_j='YES' - ;; - no) Build_j='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-j=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-k, - [--enable-user-way-k build for \`user way k' (mostly for implementors)], - [case "$enableval" in - yes) Build_k='YES' - ;; - no) Build_k='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-k=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-l, - [--enable-user-way-l build for \`user way l' (mostly for implementors)], - [case "$enableval" in - yes) Build_l='YES' - ;; - no) Build_l='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-l=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-m, - [--enable-user-way-m build for \`user way m' (mostly for implementors)], - [case "$enableval" in - yes) Build_m='YES' - ;; - no) Build_m='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-m=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-n, - [--enable-user-way-n build for \`user way n' (mostly for implementors)], - [case "$enableval" in - yes) Build_n='YES' - ;; - no) Build_n='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-n=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-o, - [--enable-user-way-o build for \`user way o' (mostly for implementors)], - [case "$enableval" in - yes) Build_o='YES' - ;; - no) Build_o='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-o=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-A, - [--enable-user-way-A build for \`user way A' (mostly for implementors)], - [case "$enableval" in - yes) Build_A='YES' - ;; - no) Build_A='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-A=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-B, - [--enable-user-way-B build for \`user way B' (mostly for implementors)], - [case "$enableval" in - yes) Build_B='YES' - ;; - no) Build_B='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-B=$enableval" - exit 1 - ;; - esac]) - -dnl We do not use AC_SUBST to communicate the Build_* info, -dnl as some seds (notably OSF) only allow 99 commands (!!!). -dnl We will do the equivalent by a HACK further down. - -# ------------------------------------------------------------------------- -dnl GHC CONFIGURATION STUFF - -dnl ** which Haskell compiler to bootstrap GHC with? -# Figure out what Haskell compiler(s) to use for booting -# -# first, the defaults... -WithGhcHc='haskell-compiler-unspecified' -WithGhcHcType='HC_UNSPECIFIED' -GhcBuilderVersion='28' - -AC_ARG_WITH(hc-for-ghc, - [ -The Haskell compiler for bootstrapping GHC (if any); this option, -if used, overrides --with-hc=<...>: - - --with-hc-for-ghc=<Haskell compiler> - ghc* => Glasgow Haskell invoked by the name given - C or c => Don't use a Haskell compiler; - build from intermediate C (.hc) files. - ], - [case "$withval" in - ghc* | glhc* ) - WithGhcHc=$withval - ;; - hbc* ) echo "HBC will not compile GHC 0.26 as is (sigh)" - exit 1 - ;; - c | C) WithGhcHc='C' - WithGhcHcType='HC_USE_HC_FILES' - ;; - *) echo "I don't understand this option: --with-hc-for-ghc=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithGhcHcType -case $WithGhcHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-ghc was properly set" - exit 1 - fi - if test $WithHcType = 'HC_GLASGOW_GHC' ; then - touch conftest.o - $WithHc -v -C conftest.o > conftest.out 2>&1 - echo '/version (\d+)\.(\d+)/ && print ($1*100+$2);' > conftest.pl - GhcBuilderVersion=`eval $PerlCmd -n conftest.pl conftest.out` - rm -rf conftest* - fi - ;; - ghc* | glhc* ) - WithGhcHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_ghc,$WithGhcHc,$ac_dir/$ac_word) - if test -z "$have_ghc_ghc"; then - echo "Can't find Glasgow Haskell to compile GHC with: $WithGhcHc" - exit 1 - else - touch conftest.o - $WithGhcHc -v -C conftest.o > conftest.out 2>&1 - echo '/version (\d+)\.(\d+)/ && print ($1*100+$2);' > conftest.pl - GhcBuilderVersion=`eval $PerlCmd -n conftest.pl conftest.out` - rm -rf conftest* - fi - ;; - c | C) WithGhcHcType='HC_USE_HC_FILES' - ;; -esac -AC_SUBST(GhcBuilderVersion) -AC_SUBST(WithGhcHc) -AC_SUBST(WithGhcHcType) - -dnl ** use portable (slow) C? -- preferably not -GhcWithRegisterised='YES' -AC_ARG_ENABLE(portable-C, - [Other things for GHC: - ---enable-portable-C use portable C (slow), not \`registerised' (fast)], - [case "$enableval" in - yes) GhcWithRegisterised='NO' - ;; - no) GhcWithRegisterised='YES' - ;; - *) echo "I don't understand this option: --enable-portable-C=$enableval" - exit 1 - ;; - esac]) - -if test $GhcWithRegisterised = 'YES'; then - case $HostPlatform in - alpha-* | hppa1.1-* | i386-* | m68k-* | mips-* | powerpc-* | sparc-* ) - ;; - *) - echo "Don't know non-portable C tricks for this platform: $HostPlatform" - GhcWithRegisterised='NO' - ;; - esac -fi -AC_SUBST(GhcWithRegisterised) - -if test $GhcWithRegisterised = 'NO'; then - Build_u='YES' - Build_normal='NO' - Build_p='NO' -fi -# ToDo: make sure we can do concurrent for platform/circs... -# ToDo: make sure we can do profiling for platform/circs... -# ToDo: make sure we can do parallel for platform/circs... -# ToDo: make sure we can do gransim for platform/circs... - -dnl ** build GHC compiler proper (\`hsc') from .hc files? -GhcWithHscBuiltViaC='NO' -AC_ARG_ENABLE(hsc-built-via-C, - [--enable-hsc-built-via-C build compiler proper (hsc) from intermediate .hc - files (disabled by default)], - [case "$enableval" in - yes) GhcWithHscBuiltViaC='YES' - ;; - no) GhcWithHscBuiltViaC='NO' - ;; - *) echo "I don't understand this option: --enable-hsc-built-via-C=$enableval" - exit 1 - ;; - esac]) -case $WithGhcHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHcType = 'HC_USE_HC_FILES' ; then - GhcWithHscBuiltViaC='YES' - fi - ;; - c | C) GhcWithHscBuiltViaC='YES' - ;; - *) ;; -esac -AC_SUBST(GhcWithHscBuiltViaC) - -dnl ** build \`hsc' with -O? -GhcWithHscOptimised='YES' -AC_ARG_ENABLE(hsc-optimised, - [--disable-hsc-optimised don't build compiler proper (hsc) with -O], - [case "$enableval" in - yes) GhcWithHscOptimised='YES' - ;; - no) GhcWithHscOptimised='NO' - ;; - *) echo "I don't understand this option: --enable-hsc-optimised=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithHscOptimised) - -dnl ** build \`hsc' with -DDEBUG? -GhcWithHscDebug='NO' -AC_ARG_ENABLE(hsc-debug, - [--enable-hsc-debug build compiler proper (hsc) with -DDEBUG], - [case "$enableval" in - yes) GhcWithHscDebug='YES' - ;; - no) GhcWithHscDebug='NO' - ;; - *) echo "I don't understand this option: --enable-hsc-debug=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithHscDebug) - -dnl ** omit native-code generator from \`hsc'? -GhcWithNativeCodeGen='YES' -AC_ARG_ENABLE(native-code-generator, - [--enable-native-code-generator build an n.c.g. - [enabled for supported platforms]], - [case "$enableval" in - yes) GhcWithNativeCodeGen='YES' - ;; - no) GhcWithNativeCodeGen='NO' - ;; - *) echo "I don't understand this option: --enable-native-code-generator=$enableval" - exit 1 - ;; - esac]) -if test $GhcWithNativeCodeGen = 'YES'; then - case $TargetPlatform in - i386-* | alpha-* | sparc-* ) - ;; - *) - echo "Don't have a native-code generator for this platform: $TargetPlatform" - GhcWithNativeCodeGen='NO' - ;; - esac -fi -AC_SUBST(GhcWithNativeCodeGen) - -dnl ** include Marlow's deforester in \`hsc'? -GhcWithDeforester='NO' -AC_ARG_ENABLE(deforester, - [--enable-deforester build deforester into compiler (HACKERS ONLY)], - [case "$enableval" in - yes) GhcWithDeforester='YES' - ;; - no) GhcWithDeforester='NO' - ;; - *) echo "I don't understand this option: --enable-deforester=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithDeforester) - -dnl ** include Readline library? -GhcWithReadline='NO' -AC_ARG_ENABLE(readline-library, - [--enable-readline-library include (GNU) readline library in -syslib GHC], - [case "$enableval" in - yes) GhcWithReadline='YES' - ;; - no) GhcWithReadline='NO' - ;; - *) echo "I don't understand this option: --enable-readline-library=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithReadline) - -dnl ** include Sockets library? -GhcWithSockets='NO' -AC_ARG_ENABLE(sockets-library, - [--enable-sockets-library include the network-interface (sockets) library in -syslib GHC], - [case "$enableval" in - yes) GhcWithSockets='YES' - ;; - no) GhcWithSockets='NO' - ;; - *) echo "I don't understand this option: --enable-sockets-library=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithSockets) - -# Here, by HACK means, we dump all the Build_ info -# into a file. See comment above. -rm -f ghc/mk/buildinfo.mk -echo creating ghc/mk/buildinfo.mk -touch ghc/mk/buildinfo.mk -for xx in normal p t u mc mr mt mp mg 2s 1s du a b c d e f g h i j k l m n o A B ; do - eval "yy=\$Build_$xx" - echo "Build_$xx = $yy" >> ghc/mk/buildinfo.mk -done - -# ------------------------------------------------------------------------- -dnl -dnl * `HsLibs' CONFIGURATION STUFF - -if test "xxx$DoingHsLibs" = 'xxxhslibs' ; then -# a very big "if"! - -dnl ** which Haskell compiler to use on hslibs? -WithHsLibsHc='haskell-compiler-unspecified' -WithHsLibsHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-hslibs, - [ -******************************************************************* -** \`HsLibs' HASKELL LIBRARIES OPTIONS: - -The Haskell compiler to compile the Haskell Libraries suite; this -option, if used, overrides --with-hc=<...>: - - --with-hc-for-hslibs=<Haskell compiler> - ghc* => Glasgow Haskell invoked by the name given - and you want to use it un-installed ("in-place").], - [case "$withval" in - ghc* | glhc* ) - WithHsLibsHc=$withval - ;; - in-place ) - WithHsLibsHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-hslibs=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHsLibsHcType -case $WithHsLibsHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-hslibs was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithHsLibsHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_hslibs,$WithHsLibsHc,$ac_dir/$ac_word) - if test -z "$have_ghc_hslibs"; then - echo "Can't find Glasgow Haskell to compile HsLibs with: $WithHsLibsHc" - exit 1 - fi - ;; - IN-PLACE) WithHsLibsHcType='HC_GLASGOW_GHC' - WithHsLibsHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHsLibsHc) -AC_SUBST(WithHsLibsHcType) - -# Here, by HACK means, we dump all the Build_ info -# into a file. See comment above. -rm -f hslibs/mk/buildinfo.mk -echo creating hslibs/mk/buildinfo.mk -cat > hslibs/mk/buildinfo.mk <<EOF -# ** DO NOT EDIT! ** -# This file is obliterated every time 'configure' is run! - -EOF -for xx in normal p t u mc mr mt mp mg 2s 1s du a b c d e f g h i j k l m n o A B ; do - eval "yy=\$Build_$xx" - echo "Build_$xx = $yy" >> hslibs/mk/buildinfo.mk -done - - -# here ends a very big if DoingHsLibs = 'hslibs' ... -fi -# -# ------------------------------------------------------------------------- -dnl -dnl * `Happy' CONFIGURATION STUFF - -if test "xxx$DoingHappy" = 'xxxhappy' ; then -# a very big "if"! - -dnl ** which Haskell compiler to use on happy? -WithHappyHc='haskell-compiler-unspecified' -WithHappyHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-happy, - [ -******************************************************************* -** \`Happy' PARSER-GENERATOR OPTIONS: - -The Haskell compiler to compile Happy; this option, if used, overrides ---with-hc=<...>: - - --with-hc-for-happy=<Haskell compiler> - ghc* => Glasgow Haskell invoked by the name given - hbc* => Chalmers HBC, invoked by the name given - nhc* => Niklas Rojemo's "nhc", invoked by the name given - in-place => Use ghc/driver/ghc; i.e. you've built GHC - and you want to use it un-installed ("in-place").], - [case "$withval" in - ghc* | glhc* ) - WithHappyHc=$withval - ;; - hbc* ) WithHappyHc=$withval - ;; - nhc* ) WithHappyHc=$withval - ;; - in-place ) - WithHappyHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-happy=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHappyHcType -case $WithHappyHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-happy was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithHappyHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_happy,$WithHappyHc,$ac_dir/$ac_word) - if test -z "$have_ghc_happy"; then - echo "Can't find Glasgow Haskell to compile Happy with: $WithHappyHc" - exit 1 - fi - ;; - hbc* ) # Look for the dastardly competition - WithHappyHcType='HC_CHALMERS_HBC' - AC_CHECK_PROG(have_hbc,$WithHappyHc,YES,NO) - if test $have_hbc = 'NO' ; then - echo "Can't find Chalmers HBC to compile with: $WithHappyHc" - exit 1 - fi - ;; - nhc* ) # Look for Niklas Rojemo's "nhc" - WithHappyHcType='HC_ROJEMO_NHC' - AC_CHECK_PROG(have_nhc,$WithHappyHc,YES,NO) - if test $have_nhc = 'NO' ; then - echo "Can't find Niklas Rojemo's NHC to compile with: $WithHappyHc" - exit 1 - fi - ;; - IN-PLACE) WithHappyHcType='HC_GLASGOW_GHC' - WithHappyHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHappyHc) -AC_SUBST(WithHappyHcType) - -# here ends a very big if DoingHappy = 'happy' ... -fi # -# ------------------------------------------------------------------------- -dnl -dnl * `Haggis' CONFIGURATION STUFF - -if test "xxx$DoingHaggis" = 'xxxhaggis' ; then -# a very big "if"! - -dnl ** which Haskell compiler to use on haggis? -WithHaggisHc='haskell-compiler-unspecified' -WithHaggisHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-haggis, - [ -******************************************************************* -** \`Haggis' HASKELL GUI TOOLKIT OPTIONS: - -The Haskell compiler to compile the Haggis toolkit; this option, if -used, overrides --with-hc=<...>: - - --with-hc-for-haggis=<Haskell compiler> - ghc* => Glasgow Haskell invoked by the name given - and you want to use it un-installed ("in-place").], - [case "$withval" in - ghc* | glhc* ) - WithHaggisHc=$withval - ;; - in-place ) - WithHaggicHs='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-haggis=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHaggisHcType -case $WithHaggisHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-haggis was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithHaggisHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_haggis,$WithHaggisHc,$ac_dir/$ac_word) - if test -z "$have_ghc_haggis"; then - echo "Can't find Glasgow Haskell to compile Haggis with: $WithHaggisHc" - exit 1 - fi - ;; - IN-PLACE) WithHaggisHcType='HC_GLASGOW_GHC' - WithHaggisHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHaggisHc) -AC_SUBST(WithHaggisHcType) - -# builds stuff?? ToDo - -# here ends a very big if DoingHaggis = 'haggis' ... -fi +# It'll break soon enough if it didn't, but we perform a sanity +# check here on the generated config.mk file to see if the +# sed that was used is of the well-behaved sort. # -# ------------------------------------------------------------------------- -dnl -dnl * `NoFib' CONFIGURATION STUFF - -if test "xxx$DoingNoFib" = 'xxxnofib' ; then -# a very big "if"! - -dnl ** which Haskell compiler to test with NoFib? -WithNoFibHc='haskell-compiler-unspecified' -WithNoFibHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-nofib, - [ -******************************************************************* -** NoFib HASKELL BENCHMARK SUITE OPTIONS: - -The Haskell compiler to compile the NoFib programs; this option, if -used, overrides --with-hc=<...>: - - --with-hc-for-nofib=<Haskell compiler> - ghc* => Glasgow Haskell invoked by the name given - hbc* => Chalmers HBC, invoked by the name given - nhc* => Niklas Rojemo's "nhc", invoked by the name given - in-place => Use ghc/driver/ghc; i.e. you've built GHC - and you want to use it un-installed ("in-place"). - ], - [case "$withval" in - ghc* | glhc* ) - WithNoFibHc=$withval - ;; - hbc* ) WithNoFibHc=$withval - ;; - nhc* ) WithNoFibHc=$withval - ;; - in-place ) - WithNoFibHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-nofib=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHappyHcType -case $WithNoFibHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-nofib was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithNoFibHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_nofib,$WithNoFibHc,$ac_dir/$ac_word) - if test -z "$have_ghc_nofib"; then - echo "Can't find Glasgow Haskell to compile NoFib with: $WithNoFibHc" - exit 1 - fi - ;; - hbc* ) # Look for the dastardly competition - WithNoFibHcType='HC_CHALMERS_HBC' - AC_CHECK_PROG(have_hbc,$WithNoFibHc,YES,NO) - if test $have_hbc = 'NO' ; then - echo "Can't find Chalmers HBC to compile NoFib with: $WithNoFibHc" - exit 1 - fi - ;; - nhc* ) # Look for Niklas Rojemo's "nhc" - WithNoFibHcType='HC_ROJEMO_NHC' - AC_CHECK_PROG(have_nhc,$WithNoFibHc,YES,NO) - if test $have_nhc = 'NO' ; then - echo "Can't find Niklas Rojemo's NHC to compile NoFib with: $WithNoFibHc" - exit 1 - fi - ;; - IN-PLACE) WithNoFibHcType='HC_GLASGOW_GHC' - WithNoFibHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithNoFibHc) -AC_SUBST(WithNoFibHcType) - -dnl ** what mkworld \`setup' should be used? -AC_ARG_WITH(setup, - [ ---with-setup=<setup> : What mkworld \`setup' should be used? - Choices: ghc, hbc, nhc -], - [case "$withval" in - ghc ) MkWorldSetup='ghc' - ;; - hbc ) MkWorldSetup='hbc' - ;; - nhc ) MkWorldSetup='nhc' - ;; - *) echo "I don't understand this option: --with-setup=$withval" - exit 1 - ;; - esac]) - -if test $MkWorldSetup = 'std' ; then - echo 'You must do --with-setup=... (one of: ghc, hbc, or nhc) for NoFib' - exit 1 -fi - -# --------------------------------------- -# What sets of tests should be run. -# -IncludeRealNoFibTests='YES' # defaults -IncludeSpectralNoFibTests='YES' -IncludeImaginaryNoFibTests='YES' -IncludeSpecialiseNoFibTests='NO' -IncludeGHC_ONLYNoFibTests='NO' -IncludePRIVATENoFibTests='NO' -IncludeParallelNoFibTests='NO' - -dnl ** should *all* NoFib tests be run? -# special catch-all variant -AC_ARG_ENABLE(all-tests, - [Possibly turn on *all* of the possible tests (a sane choice -only if using GHC): - ---enable-all-tests do *all* tests], - [case "$enableval" in - yes) IncludeGHC_ONLYNoFibTests='YES' - IncludeSpecialiseNoFibTests='YES' - IncludePRIVATENoFibTests='YES' - IncludeParallelNoFibTests='YES' - ;; - no) IncludeGHC_ONLYNoFibTests='NO' - IncludeSpecialiseNoFibTests='NO' - IncludePRIVATENoFibTests='NO' - IncludeParallelNoFibTests='NO' - - IncludeRealNoFibTests='NO' - IncludeSpectralNoFibTests='NO' - IncludeImaginaryNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-all-tests=$enableval" - exit 1 - ;; - esac]) - -dnl ** turn on/off individual categories of tests... -# individual categories -AC_ARG_ENABLE(imaginary-tests, - [ -Enable/disable individual categories of tests: - ---disable-imaginary-tests do *not* include imaginary tests], - [case "$enableval" in - yes) IncludeImaginaryNoFibTests='YES' - ;; - no) IncludeImaginaryNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-imaginary-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(spectral-tests, - [--disable-spectral-tests do *not* include spectral tests], - [case "$enableval" in - yes) IncludeSpectralNoFibTests='YES' - ;; - no) IncludeSpectralNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-spectral-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(real-tests, - [--disable-real-tests do *not* include real tests], - [case "$enableval" in - yes) IncludeRealNoFibTests='YES' - ;; - no) IncludeRealNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-real-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(GHC-ONLY-tests, - [--enable-GHC-ONLY-tests include GHC_ONLY tests], - [case "$enableval" in - yes) IncludeGHC_ONLYNoFibTests='YES' - ;; - no) IncludeGHC_ONLYNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-GHC-ONLY-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(specialise-tests, - [--enable-specialise-tests include specialisation tests], - [case "$enableval" in - yes) IncludeSpecialiseNoFibTests='YES' - ;; - no) IncludeSpecialiseNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-specialise-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(PRIVATE-tests, - [--enable-PRIVATE-tests include PRIVATE tests], - [case "$enableval" in - yes) IncludePRIVATENoFibTests='YES' - ;; - no) IncludePRIVATENoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-PRIVATE-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(parallel-tests, - [--enable-parallel-tests include parallel tests -], - [case "$enableval" in - yes) IncludeParallelNoFibTests='YES' - ;; - no) IncludeParallelNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-parallel-tests=$enableval" - exit 1 - ;; - esac]) - -dnl not AC_SUBSTd because of 99-command seds (sigh) -dnl (See what follows instead) -dnl AC_SUBST(IncludeRealNoFibTests) -dnl AC_SUBST(IncludeSpectralNoFibTests) -dnl AC_SUBST(IncludeImaginaryNoFibTests) -dnl AC_SUBST(IncludeGHC_ONLYNoFibTests) -dnl AC_SUBST(IncludeSpecialiseNoFibTests) -dnl AC_SUBST(IncludePRIVATENoFibTests) -dnl AC_SUBST(IncludeParallelNoFibTests) - -# Here, by HACK means, we dump all the Include*NoFibTests info -# into a file. See comment above. -rm -f nofib/mk/buildinfo.mk -echo creating nofib/mk/buildinfo.mk -cat > nofib/mkworld/buildinfo.jm <<EOF -# ** DO NOT EDIT! ** -# This file is obliterated every time 'configure' is run! - -EOF -for xx in Real Spectral Imaginary GHC_ONLY Specialise PRIVATE Parallel ; do - eval "yy=\$Include${xx}NoFibTests" - echo "Include${xx}NoFibTests = $yy" >> nofib/mk/buildinfo.mk -done - -# Here, by HACK means, we add all the Build_ info -# into a file. See comment above. - -for xx in normal p t u mc mr mt mp mg 2s 1s du a b c d e f g h i j k l m n o A B ; do - eval "yy=\$Build_$xx" - echo "Build_$xx = $yy" >> nofib/mk/buildinfo.mk -done - -# here ends a very big if DoingNoFib = 'nofib' ... +grep @ mk/config.mk > conftest.out +if grep -v '# enclosed in @at-signs@.' conftest.out >/dev/null 2>&1; then + : +else + echo 'Hmm..suspicious, did the configure script perform all the @..@ substitutions in mk/config.mk?..'; + grep -v '# enclosed in @at-signs@.' conftest.out /dev/null fi -# -# ------------------------------------------------------------------------- -dnl -dnl * extract non-header files with substitution (end) -# -AC_SUBST(MkWorldSetup) - -AC_OUTPUT(mk/platform.mk mk/utils.mk mk/install.mk ghc/mk/ghcconfig.mk ghc/includes/platform.h) +rm -f conftest* +echo '' echo '************************************************' -echo '*** NOW DO: make boot; make all' +echo '*** NOW DO: gmake boot followed by gmake all' echo '************************************************' exit 0 diff --git a/distrib/Makefile-bin.in b/distrib/Makefile-bin.in new file mode 100644 index 0000000000..404f4d126b --- /dev/null +++ b/distrib/Makefile-bin.in @@ -0,0 +1,137 @@ +# Instructions for configuring an fptools package. +# +# There are two ways you can get started with an fptools package, either +# by using the unpacked distribution tree in-situ or by installing the +# package. +# +# Using the package directly is easy, just do `make config', i.e., +# the distribution will *not* work out-of-the-box, you'll have to do +# this first. +# +# To install the package, you'll have to set one or more of the +# following variables: +# +# * bindir +# path to directory of where you want the executables +# to be installed. +# * libdir +# where you want the library archives to go. +# Note, if you specify /usr/foo/lib for libdir, +# the library files for your fptools package will be +# installed in /usr/foo/lib/<package>-<version>, i.e., +# /usr/foo/lib/ghc-2.02. If you don't want the package/version +# directory appended, you'll have to modify $(real_libdir) +# below. +# +# * datadir +# path to where the platform-independent files will go. +# As for libdir, the effective path for the platform-indep +# stuff is $(datadir)/<package>-<version>. If you want +# complete control, see $(real_libdir) +# +# * platform +# the platform you're installing for. The configure +# makes an educated guess what it, so you will only +# have to set this if it clashes with your reality. +# +# * infodir +# where to install the Emacs info files +# * htmldir +# where to install the documentation HTML files. +# * dvidir +# where to install the DVI files. +# +# Installing the documentation is not via the `install' rule, but +# via the rules: `install-docs', `install-html', `install-dvi' +# and `install-info'. +# +# For more complete instructions, consult the INSTALL file +# that came with the bundle, and/or consult the installation +# documentation in one of the document directories. +# +bindir = @bindir@ +libdir = @libdir@ +datadir = @datadir@ +platform = @platform@ + +infodir = @infodir@ +htmldir = @htmldir@ +dvidir = @dvidir@ + +# +# Putting the package stuff in package-specific +# directories: +# +real_libdir = $(libdir)/$(package)-$(version) +real_datadir = $(datadir)/$(package)-$(version) + + + + +package = ghc +version = 2.02 +PERL = @PerlCmd@ + +.PHONY: config install install-dirs + +config: + @echo Configuring $(package), version $(version), on $(platform) + @RM `pwd`/bin/$(platform)/$(package)-$(version)/$(package)-$(version) + @RM `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @echo $(PerlCmd) > `pwd`/bin/$(platform)/$(package) + @echo "$""bindir='"`pwd`"/bin/$(platform)/$(package)-$(version)';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @echo "$""libdir='"`pwd`"/lib/$(platform)/$(package)-$(version)';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @echo "$""datadir='"`pwd`"/share/$(platform)/$(package)-$(version)';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @cat `pwd`/bin/$(platform)/$(package)-$(version)/$(package).prl';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @(cd `pwd`/bin/$(platform)/$(package)-$(version); $(LN_S) $(package) $(package)-$(version) ) + @echo Finished..to use, add `pwd`/bin/$(platform)/$(package)-$(version) to your PATH. + +libdirs = . imports include +datadirs = . include + +install-dirs: + $(MKDIRHIER) $(bindir) + @for i in $(libdirs) ; do \ + echo (MKDIRHIER) $(real_libdir)/$$i; \ + (MKDIRHIER) $(real_libdir)/$$i; \ + done; + @for i in $(datadirs) ; do \ + echo (MKDIRHIER) $(real_datadir)/$$i; \ + (MKDIRHIER) $(real_datadir)/$$i; \ + done; + +install : install-dirs + +install : + $(INSTALL_PROGRAM) `pwd`/bin/$(platform)/$(package)-$(version)/* $(bindir) + @for i in $(libdirs); do \ + echo $(INSTALL) `pwd`/lib/$(platform)/$(package)-$(version)/$$i/* $(real_libdir)/$$i; \ + $(INSTALL) `pwd`/lib/$(platform)/$(package)-$(version)/$$i/* $(real_libdir)/$$i; \ + done; + @for i in $(datadirs); do \ + echo $(INSTALL) `pwd`/share/$(package)-$(version)/$$i/* $(real_datadir)/$$i; \ + $(INSTALL) `pwd`/share/$(package)-$(version)/$$i/* $(real_datadir)/$$i; \ + done; + +install-docs : install-info install-html install-dvi + +install-dirs-html: + $(MKDIRHIER) $(htmldir) + +install-dirs-info: + $(MKDIRHIER) $(infodir) + +install-dirs-dvi: + $(MKDIRHIER) $(dvidir) + +install-docs : install-html install-info install-dvi + +install-dvi: install-dirs-dvi + $(INSTALL) `pwd`/dvi/$(package)-$(version)/* $(dvidir) + +install-info: install-dirs-info + $(INSTALL) `pwd`/info/$(package)-$(version)/* $(infodir) + +install-html: install-dirs-html + $(INSTALL) `pwd`/html/$(package)-$(version)/* $(htmldir) + diff --git a/distrib/configure-bin.in b/distrib/configure-bin.in new file mode 100644 index 0000000000..88579d28b7 --- /dev/null +++ b/distrib/configure-bin.in @@ -0,0 +1,133 @@ +dnl +dnl Binary distribution configure script +dnl +#!/bin/sh +# + +AC_INIT(Makefile.in) + +# +# First off, what system are we running under? +# +AC_CANONICAL_SYSTEM + +dnl ** canonicalize platform names +# Canonicali[sz]e the platform name +TargetPlatform=`/bin/sh $srcdir/config.sub $target` || exit 1 + +# +# The following will be more difficult when we *are* cross-compiling. +# Suitable names to slam in *_CPP are in platform.h.in. +# We also record the architecture, vendor, and operating system (OS) +# separately. +case $HostPlatform in +alpha-dec-osf[[1234]]*) + TargetPlatform=alpha-dec-osf1;; +hppa1.1-hp-hpux*) + TargetPlatform=hppa1.1-hp-hpux;; +i[[3456]]86-*-linuxaout*) + TargetPlatform=i386-unknown-linuxaout;; +i[[3456]]86-*-linux*) + TargetPlatform=i386-unknown-linux;; +i[[3456]]86-*-freebsd*) + TargetPlatform=i386-unknown-freebsd;; +i[[3456]]86-*-netbsd*) + TargetPlatform=i386-unknown-netbsd;; +i[[3456]]86-*-solaris2*) + TargetPlatform=i386-unknown-solaris2;; +i[[3456]]86-*-cygwin32*) + TargetPlatform=i386-unknown-cygwin32;; +m68k-next-nextstep2) + TargetPlatform=m68k-next-nextstep2;; +m68k-next-nextstep3) + TargetPlatform=m68k-next-nextstep3;; +i[[3456]]86-next-nextstep3) + TargetPlatform=i386-next-nextstep3 +m68k-sun-sunos4*) + TargetPlatform=m68k-sun-sunos4 #hack +mips-dec-ultrix*) + TargetPlaformP=mips-dec-ultrix;; +mips-sgi-irix*) + TargetPlatform=mips-sgi-irix;; +powerpc-ibm-aix*) + TargetPlatform=powerpc-ibm-aix;; +sparc-sun-sunos4*) + TargetPlatform=sparc-sun-sunos4;; +sparc-sun-solaris2*) + TargetPlatform=sparc-sun-solaris2;; +*) + echo "Unrecognised platform: $TargetPlatform" + exit 1 + ;; +esac +echo "Which we'll canonicalise into: $TargetPlatform" + +platform=$TargetPlatform +AC_SUBST(platform) + +AC_CHECK_PROG(PerlCmd,perl,$ac_dir/$ac_word) +if test -z "$PerlCmd"; then + echo "You must install perl before you can continue" + echo "Perhaps it is already installed, but not in your PATH?" + exit 1 +else + $PerlCmd -v >conftest.out 2>&1 + if egrep "version 4" conftest.out >/dev/null 2>&1; then + if egrep "Patch level: 35" conftest.out >/dev/null 2>&1; then + echo " +************************************************************************ +Uh-oh...looks like you have Perl 4.035. + +Perl version 4.035 has a bug to do with recursion that will bite if +you run the lit2texi script, when making Info files from +literate files of various sorts. Either use the current version +(4.036), an older version (e.g., perl 4.019) or apply the patch in +glafp-utils/perl-4.035-fixes to your 4.035 perl. +************************************************************************ +" + fi + else + if egrep "version 5" conftest.out >/dev/null 2>&1; then + : + else + echo "I'm not sure if your version of perl will work," + echo "but it's worth a shot, eh?" + fi + fi + rm -fr conftest* +fi +# +dnl ** does #!.../perl work? (sometimes it's too long...) +echo "checking if \`#!$PerlCmd' works in shell scripts" +echo "#!$PerlCmd"' +exit $1; +' > conftest +chmod u+x conftest +(SHELL=/bin/sh; export SHELL; ./conftest 69 > /dev/null) +if test $? -ne 69; then + echo "It does!" +else + echo "It doesn't! Perhaps \`#!$PerlCmd' is too long (often 32 characters max)" + exit 1 +fi +rm -f conftest +# +dnl ** check if perl library is properly installed +# (by seeing if a "do 'getopts.pl'" works... +if $PerlCmd -e 'do "getopts.pl" || exit(1); exit(0);' > /dev/null 2>&1 ; then + : +else + echo "I think your perl library is misinstalled." + echo "The following script did not work:" + echo ' do "getopts.pl" || exit(1); exit(0);' + exit 1 +fi + +dnl ** figure out how to do a BSD-ish install +# +AC_PROG_INSTALL +# + + +AC_OUTPUT(Makefile) + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000000..851469d476 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,8 @@ +TOP = .. +include $(TOP)/mk/boilerplate.mk + +DOC_SRCS = installing.lit release.lit + +SRC_TEXI2HTML_OPTS += -number -monolithic -invisible xbm + +include $(TOP)/mk/target.mk diff --git a/docs/installing.lit b/docs/installing.lit new file mode 100644 index 0000000000..81bdeee2f0 --- /dev/null +++ b/docs/installing.lit @@ -0,0 +1,1730 @@ +% Building and installing the Glasgow Functional Programming Tools Suite +% +% Version 2.02 +% Feb 1997 + + + + +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Building and installing the Glasgow Functional Programming Tools Suite\\ +Version~2.02} +\author{The GHC Team\\ +Department of Computing Science\\ +University of Glasgow\\ +Glasgow, Scotland\\ +G12 8QQ\\ +\\ +Email: glasgow-haskell-\{users,bugs\}\@dcs.gla.ac.uk} +\maketitle +\begin{rawlatex} +\tableofcontents +\end{rawlatex} +\clearpage +\end{onlystandalone} + +This guide is intended for people who want to install or modify +programs from the Glasgow @fptools@ suite (as distinct from those +who merely want to {\em run} them. + +The whole install-and-make system has been completely re-done +between GHC 2.01 and 2.02, so it will be worth your while to re-read this guide +even if you have done so before. + +\section{Getting the Glasgow @fptools@ suite} + +Building the Glasgow tools {\em can} be complicated, mostly because +there are so many permutations of what/why/how, e.g., ``Build Happy +with HBC, everything else with GHC, leave out profiling, and test it +all on the `real' NoFib programs.'' Yeeps! + +Happily, such complications don't apply to most people. A few common +``strategies'' serve most purposes. Pick one and proceed +as suggested: + +\begin{description} +\item[Binary distribution.] If your only purpose is to install +some of the @fptools@ suite then the easiest thing to do is to +get a binary distribution. In the binary distribution everything is +pre-compiled for your particular machine architecture and operating +system, so all you should have to do is install the binaries and libraries +in suitable places. {\em Need pointer to info about doing binary installation.} + +A binary distribution may not work for you for two reasons. +First, we may not have built the suite for the particular +architecture/OS platform you want. That may be due to lack of time and +energy (in which case you can get a source distribution and build from it; +see below). Alternatively, it may be because we havn't yet ported the +suite to your architecture, in which case you are considerably worse off. + +The second reason a binary distribution may not be what you want is +if you want to read or modify the souce code. + +\item[Source distribution.] +You have a supported +platform, but (a)~you like the warm fuzzy feeling of compiling things +yourself; (b)~you want to build something ``extra''---e.g., a set of +libraries with strictness-analysis turned off; or (c)~you want to hack +on GHC yourself. + +A source distribution contains complete sources for the @fptools@ suite. +Not only that, but the more awkward machine-independent steps are done +for you. For example, if you don't have @flex@ you'll it convenient that +the source distribution contains the result of running @flex@ on the +lexical analyser specification. If you don't want to alter the lexical +analyser then this saves you having to find and install @flex@. +You will still need a working version of GHC on your machine in order to +compile (most of) the sources, however. + + +\item[Build GHC from intermediate C \tr{.hc} files:] +You need a working GHC to use a source distribution. What if you don't have a working GHC? +Then you have no choice but to ``bootstrap'' up from the +intermediate C (\tr{.hc}) files that we provide. +Building GHC on an unsupported platform falls into this category. +Please see \sectionref{booting-from-C}. + +NB: For GHC~2.01, bootstrapping from \tr{.hc} files means you will get +an all-2.01 system---possibly unduly slow. Building with GHC~0.29 +will get you a faster compiler... + +Once you have built GHC, you can build the other Glasgow tools with +it. + +In theory, you can build GHC with another Haskell compiler (e.g., +HBC). We havn't tried to do this for ages and it almost certainly +doesn't work any more. + +\item[The CVS repository.] +We make source distributions at the same time as binary distributions; +i.e. infrequently. They should, however, be pretty throughly tested. +If you want more up-to-the minute (but less tested) source code then you +need to get access to our CVS repository. + +All the @fptools@ source code is held in a CVS repository. +CVS is a pretty good source-code control system, and best of all it works over the network. + +The repository holds source code only. It holds no mechanically generated +files at all. So if you check out a source tree from CVS you will need +to install every utility so that you can build all the derived files +from scratch. + +Giving you access to the repository entails some systems administration +at our end; and we are a bit nervous about being submerged in bug reports +about our current working copy (which is, by definition, in flux). So +we are a bit cautious about offering CVS access. Feel free to ask though! +\end{description} + +If you are going to do any building from sources (either from a source +distribution or the CVS repository) then you need to read all of this manual in detail. + + +%************************************************************************ +%* * +\section{Things to check before you start typing} +%* * +%************************************************************************ + +Here's a list of things to check before you get started. +\begin{enumerate} +\item +\index{disk space needed} +Disk space needed: About 30MB (five hamburgers' worth) of disk space +for the most basic binary distribution of GHC; more for some +platforms, e.g., Alphas. An extra ``bundle'' (e.g., concurrent +Haskell libraries) might take you to 8--10 hamburgers. + +You'll need over 100MB (say, 20 hamburgers' worth) if you need to +build the basic stuff from scratch. + +I don't yet know the disk requirements for the non-GHC tools. + +All of the above are {\em estimates} of disk-space needs. + +\item +Use an appropriate machine, compilers, and things. + +SPARC boxes and DEC Alphas running OSF/1 are fully supported. +Linux, MIPS, and HP boxes are in pretty good shape. +\Sectionref{port-info} gives the full run-down on ports or lack +thereof. + +\item +Be sure that the ``pre-supposed'' utilities are installed. +Section~\ref{sect_std-utils} elaborates. + +\item +If you have any problem when building or installing the Glasgow tools, +please check the ``known pitfalls'' (\sectionref{build-pitfalls}). If +you feel there is still some shortcoming in our procedure or +instructions, please report it. + +For GHC, please see the bug-reporting section of the User's guide +(separate document), to maximise the usefulness of your report. + +If in doubt, please send a message to +\tr{glasgow-haskell-bugs@dcs.gla.ac.uk}. +\end{enumerate} + + +%************************************************************************ +%* * +\section[port-info]{What machines the Glasgow tools, version~2.01, run on} +\index{ports, GHC} +\index{GHC ports} +\index{supported platforms} +\index{platforms, supported} +%* * +%************************************************************************ + +The main question is whether or not the Haskell compiler (GHC) runs on +your platform. + +A ``platform'' is a +architecture/manufacturer/operating-system combination, +such as @sparc-sun-solaris2.5.1@. Other common ones are +@alpha-dec-osf2@, @hppa1.1-hp-hpux9@, @i386-unknown-linux@, +@i386-unknown-solaris2@, @i386-unknown-freebsd@, +@m68k-sun-sunos4@, @mips-sgi-irix5@, +@sparc-sun-sunos4@, @sparc-sun-solaris2@. + +Bear in mind that certain ``bundles'', e.g. parallel Haskell, may not +work on all machines for which basic Haskell compiling is supported. + +Some libraries may only work on a limited number of platforms; for +example, a sockets library is of no use unless the operating system +supports the underlying BSDisms. + +%************************************************************************ +%* * +\subsection{What platforms the Haskell compiler (GHC) runs on} +%* * +%************************************************************************ +\index{fully-supported platforms} +\index{native-code generator} +\index{registerised ports} +\index{unregisterised ports} + +The GHC hierarchy of Porting Goodness: (a)~Best is a native-code +generator; (b)~next best is a ``registerised'' +port; (c)~the bare minimum is an ``unregisterised'' port. +``Unregisterised'' is so terrible that we won't say more about it. + +We use Sun4s running SunOS~4.1.3 and Solaris 2.5, and DEC~Alphas +running OSF/1~V2.0, so those are the ``fully-supported'' platforms, +unsurprisingly. Both have native-code generators, for quicker +compilations. The native-code generator for iX86 platforms (e.g., +Linux ELF) is {\em nearly} working; but is not turned on by default. + +Here's everything that's known about GHC ports, as of 2.01. We +identify platforms by their ``canonical GNU-style'' names. + +Note that some ports are fussy about which GCC version you use; or +require GAS; or ... + +\begin{description} +%------------------------------------------------------------------- +\item[\tr{alpha-dec-osf1}:] +\index{alpha-dec-osf1: fully supported} +(We have OSF/1 V2.0.) Fully supported, including native-code generator. +We recommend GCC 2.6.x or later. + +%------------------------------------------------------------------- +\item[\tr{sparc-sun-sunos4}:] +\index{sparc-sun-sunos4: fully supported} +Fully supported, including native-code generator. + +%------------------------------------------------------------------- +\item[\tr{sparc-sun-solaris2}:] +\index{sparc-sun-solaris2: fully supported} +Fully supported, including native-code generator. A couple of quirks, +though: (a)~the profiling libraries are bizarrely huge; (b)~the +default \tr{xargs} program is atrociously bad for building GHC +libraries (see \sectionref{Pre-supposed} for details). + +%------------------------------------------------------------------- +\item[HP-PA box running HP/UX 9.x:] +\index{hppa1.1-hp-hpux: registerised port} +Works registerised. No native-code generator. +For GCC, you're best off with one of the Utah releases of +GCC~2.6.3 (`u3' or later), from \tr{jaguar.cs.utah.edu}. +We think a straight GCC 2.7.x works, too. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{hppa1.1-hp-hpux: concurrent---no} +\index{hppa1.1-hp-hpux: parallel---no} + +%------------------------------------------------------------------- +\item[\tr{i386-*-linux} (PCs running Linux---ELF format):] +\index{i386-*-linux: registerised port} +GHC~2.01 works registerised. +You {\em must} have GCC 2.7.x or later. +The iX86 native-code generator is {\em nearly} there, but it +isn't turned on by default. + +Profiling works, and Concurrent Haskell works. +\index{i386-*-linux: profiling---yes} +\index{i386-*-linux: concurrent---yes} +Parallel Haskell probably works. +\index{i386-*-linux: parallel---maybe} + +On old Linux a.out systems: should be the same. +\index{i386-*-linuxaout: registerised port} + +%------------------------------------------------------------------- +\item[\tr{i386-*-*bsd} (PCs running FreeBSD (and NetBSD?):] +\index{i386-*-freebsd: registerised port} +GHC~2.01 works registerised. Supports same set of bundles +as the above. + +\index{i386-*-freebsd: profiling---yes} +\index{i386-*-freebsd: concurrent---yes} +\index{i386-*-freebsd: parallel---maybe} + +%------------------------------------------------------------------- +\item[\tr{i386-unknown-cygwin32}:] +\index{i386-unknown-cygwin32: fully supported} +Fully supported under Win95/NT, including a native +code generator. Requires the @cygwin32@ compatibility library and +a healthy collection of GNU tools (i.e., gcc, GNU ld, bash etc.) +Profiling works, so does Concurrent Haskell. +\index{i386-*-cygwin32: profiling---yes} +\index{i386-*-cygwin32: concurrent---yes} + +% ToDo: more documentation on this is reqd here. + +%------------------------------------------------------------------- +\item[\tr{mips-sgi-irix5}:] +\index{mips-sgi-irix5: registerised port} +GHC~2.01 works registerised (no native-code generator). +I suspect any GCC~2.6.x (or later) is OK. The GCC that I used +was built with \tr{--with-gnu-as}; turns out that is important! + +Concurrent/Parallel Haskell probably don't work (yet). +Profiling might work, but it is untested. +\index{mips-sgi-irix5: concurrent---no} +\index{mips-sgi-irix5: parallel---no} +\index{mips-sgi-irix5: profiling---maybe} + +%------------------------------------------------------------------- +\item[\tr{m68k-apple-macos7} (Mac, using MPW):] +\index{m68k-apple-macos7: historically ported} +Once upon a time, David Wright in Tasmania has actually +gotten GHC to run on a Macintosh. Ditto James Thomson here at Glasgow. +You may be able to get Thomson's from here. (Not sure that it will +excite you to death, but...) + +No particularly recent GHC is known to work on a Mac. + +%------------------------------------------------------------------- +\item[\tr{m68k-next-nextstep3}:] +\index{m68k-next-nextstep3: historically ported} +Carsten Schultz succeeded with a ``registerised'' port of GHC~0.19. +There's probably a little bit-rot since then, but otherwise it should +still be fine. Had a report that things were basically OK at 0.22. + +Concurrent/Parallel Haskell probably won't work (yet). +\index{m68k-next-nextstep3: concurrent---no} +\index{m68k-next-nextstep3: parallel---no} + +%------------------------------------------------------------------- +\item[\tr{m68k-sun-sunos4} (Sun3):] +\index{m68k-sun-sunos4: registerised port} +GHC~2.01 hasn't been tried on a Sun3. GHC~0.26 worked registerised. +No native-code generator. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{m68k-sun-sunos4: concurrent---no} +\index{m68k-sun-sunos4: parallel---no} +\end{description} + +%************************************************************************ +%* * +\subsection{What machines the other tools run on} +%* * +%************************************************************************ + +Unless you hear otherwise, the other tools work if GHC works. + +Haggis requires Concurrent Haskell to work. +\index{Haggis, Concurrent Haskell} + + +%************************************************************************ +%* * +\section[installing-bin-distrib]{Installing from binary distributions} +\index{binary installations} +\index{installation, of binaries} +%* * +%************************************************************************ + +Installing from binary distributions is easiest, and recommended! +(Why binaries? Because GHC is a Haskell compiler written in Haskell, +so you've got to ``bootstrap'' it, somehow. We provide +machine-generated C-files-from-Haskell for this purpose, but it's +really quite a pain to use them. If you must build GHC from its +sources, using a binary-distributed GHC to do so is a sensible way to +proceed. For the other @fptools@ programs, many are written in Haskell, +so binary distributions allow you to install them without having a Haskell compiler.) + + +\subsection{Bundle structure} + +Binary distributions come in ``bundles,''\index{bundles of binary stuff} +one bundle per file called \tr{<bundle>-<platform>.tar.gz}. +(See Section~\ref{port-info} for what a platform is.) +Suppose that you untar a binary-distribution bundle, thus: +\begin{verbatim} + % cd /your/scratch/space + % gunzip < ghc-2.02-sun-sparc-solaris2.tar.gz | tar xvf - +\end{verbatim} +Then you should find a single directory, @fptools@, with the following +structure: +\begin{description} +\item[@Makefile.in@] the raw material from which the @Makefile@ will be made (\sectionref{sect_install}). +\item[@configure@] the configuration script (\sectionref{sect_install}). +\item[@README@] Contains this file summary. +\item[@INSTALL@] Contains this description of how to install the bundle. +\item[@ANNOUNCE-<bundle>@] The announcement message for the bundle. +\item[@NEWS-<bundle>@] release notes for the bundle -- a longer version of @ANNOUNCE@. +\item[@bin/<platform>/@] contains platform-specific executable files to be invoked +directly by the user. These are the files that must end up in your path. +\item[@lib/<platform>@] contains platform-specific support files for the installation. +Typically there is a subdirectory for each @fptools@ project, whose name is +the name of the project with its version number. +For example, for GHC 2.02 there would be a sub-directory @ghc-2.02/@. + +These sub-directories have the following general structure: +\begin{description} +\item[@libHS.a@ etc:] supporting library archives. +\item[@ghc-iface.prl@ etc:] support scripts. +\item[@import/@] Interface files (@.hi@) for the prelude. +\item[@include/@] A few C @#include@ files. +\end{description} + +\item[@share/@] contains platform-independent support files for the installation. +Again, there is a sub-directory for each @fptools@ project. + +\item[@info/@] contains Emacs info documentation files (one sub-directory per project). +\item[@html/@] contains HTML documentation files (one sub-directory per project). +\item[@man/@] contains Unix manual pages. +\end{description} +This structure is designed so that you can unpack multiple bundles (including +ones from different releases or platforms) into a single @fptools@ directory: +\begin{verbatim} + % cd /your/scratch/space + % gunzip < ghc-2.02-sun-sparc-solaris2.tar.gz | tar xvf - + % gunzip < happy-1.09-sun-sparc-sunos4.tar.gz | tar xvf - +\end{verbatim} +When you do multiple unpacks like this, the top level @Makefile@, @README@, +and @INSTALL@ get overwritten each time. That's fine -- they should be the same. +Likewise, the @ANNOUNCE-<bundle>@ and @NEWS-<bundle>@ files will be duplicated +across multiple platforms, so they will be harmlessly overwritten when you do +multiple unpacks. +Finally, the @share/@ stuff will get harmlessly overwritten when you do multiple +unpacks for one bundle on different platforms. + +\subsection[sect_install]{Installing} + +OK, so let's assume that you have unpacked your chosen bundles into +a scratch directory @fptools@. What next? Well, you will at least need +to run the @configure@ script by changing your directory to @fptools@. +That should convert @Makefile.in@ to @Makefile@. + +You can now either start using the tools {\em in-situ} without going +through any installation process, just type @make config@ to set the +tools up for this (you have to be in the @fptools@ directory). You'll +also want to add the path which @make@ echoes to your @PATH@ +environment variable. This option is useful if you simply want to try +out the package or you don't have the necessary priviledges (or +inclination) to properly install the tools locally. Note that if you +do decide to install the package `properly' at a later date, you have +to go through the installation steps that +follows. + +To install an @fptools@ package, you'll have to do the following: + +\begin{enumerate} +\item Edit the @Makefile@ and check the settings of the following variables: +\begin{description} +\item[@platform@] the platform you are going to install for. +\item[@bindir@] the directory in which to install user-invokable binaries. +\item[@libdir@] the directory in which to install platform-dependent support files. +\item[@datadir@] the directory in which to install platform-independent support files. +\item[@infodir@] the directory in which to install Emacs info files. +\item[@htmldir@] the directory in which to install HTML documentation. +\item[@dvidir@] the directory in which to install DVI documentation. +\end{description} +The values for these variables can be set through invocation of the +@configure@ script that comes with the distribution, but doing an optical +diff to see if the values match your expectations is always a Good Idea. + +{\em Instead of running @configure@, it is perfectly OK to copy +@Makefile.in@ to @Makefile@ and set all these variables directly +yourself. But do it right!} + +\item Run @make install@. This {\em should} works with ordinary Unix +@make@ -- no need for fancy stuff like GNU @make@. + +\item \tr{rehash} (t?csh users), so your shell will see the new stuff +in your bin directory. + +\item +Once done, test your ``installation'' as suggested in +\sectionref{GHC_test}. Be sure to use a \tr{-v} option, so you +can see exactly what pathnames it's using. + +If things don't work as expected, check the list of know pitfalls +\sectionref{build-pitfalls}. +\end{enumerate} + +When installing the user-invokable binaries, this installation +procedure will install, say, @GHC@ version 2.02 as @ghc-2.02@. It +will also make a link (in the binary installation directory) from +@ghc@ to @ghc-2.02@. If you install multiple versions of GHC then the +last one ``wins'', and ``@ghc@'' will invoke the last one installed. +You can change this manually if you want. But regardless, @ghc-2.02@ +should always invoke @GHC@ version 2.02. + +\subsection{What bundles there are} + +There are plenty of ``non-basic'' GHC bundles. The files for them are +called \tr{ghc-2.01-<bundle>-<platform>.tar.gz}, where the +\tr{<platform>} is as above, and \tr{<bundle>} is one of these: +\begin{description} +\item[\tr{prof}:] Profiling with cost-centres. You probably want this. + +\item[\tr{conc}:] Concurrent Haskell features. You may want this. + +\item[\tr{par}:] Parallel Haskell features (sits on top of PVM). +You'll want this if you're into that kind of thing. + +\item[\tr{gran}:] The ``GranSim'' parallel-Haskell simulator +(hmm... mainly for implementors). + +\item[\tr{ticky}:] ``Ticky-ticky'' profiling; very detailed +information about ``what happened when I ran this program''---really +for implementors. + +\item[\tr{prof-conc}:] Cost-centre profiling for Concurrent Haskell. + +\item[\tr{prof-ticky}:] Ticky-ticky profiling for Concurrent Haskell. +\end{description} + +One likely scenario is that you will grab {\em three} binary +bundles---basic, profiling, and concurrent. + + + +%************************************************************************ +%* * +\subsection[GHC_test]{Test that GHC seems to be working} +\index{testing a new GHC} +%* * +%************************************************************************ + +The way to do this is, of course, to compile and run {\em this} program +(in a file \tr{Main.hs}): +\begin{verbatim} +main = putStr "Hello, world!\n" +\end{verbatim} + +First, give yourself a convenient way to execute the driver script +\tr{ghc/driver/ghc}, perhaps something like... +\begin{verbatim} +% ln -s /local/src/ghc-2.01/ghc/driver/ghc ~/bin/alpha/ghc +% rehash +\end{verbatim} + +Compile the program, using the \tr{-v} (verbose) flag to verify that +libraries, etc., are being found properly: +\begin{verbatim} +% ghc -v -o hello Main.hs +\end{verbatim} + +Now run it: +\begin{verbatim} +% ./hello +Hello, world! +\end{verbatim} + +Some simple-but-profitable tests are to compile and run the +notorious \tr{nfib} program, using different numeric types. Start +with \tr{nfib :: Int -> Int}, and then try \tr{Integer}, \tr{Float}, +\tr{Double}, \tr{Rational} and maybe \tr{Complex Float}. Code +for this is distributed in \tr{ghc/misc/examples/nfib/}. + +For more information on how to ``drive'' GHC, +either do \tr{ghc -help} or consult the User's Guide (distributed in +\tr{ghc/docs/users_guide}). + + +%************************************************************************ +%* * +\section[Pre-supposed]{Installing pre-supposed utilities} +\index{pre-supposed utilities} +\index{utilities, pre-supposed} +%* * +%************************************************************************ + +\label{sect_std-utils} + +Here are the gory details about some utility programs you may need; +\tr{perl} and \tr{gcc} are the only important ones. (PVM is important +if you're going for Parallel Haskell.) The \tr{configure} script will +tell you if you are missing something. + +\begin{description} +\item[Perl:] +\index{pre-supposed: Perl} +\index{Perl, pre-supposed} +{\em You have to have Perl to proceed!} Perl is a language quite good +for doing shell-scripty tasks that involve lots of text processing. +It is pretty easy to install. + +(Perl~5 is the current version; GHC might be Perl~4 friendly, we've +run into some trouble with our scripts on \tr{alpha-dec-osf\{1,2\}} +using Perl~4 (patchlevel 36)) + +Perl should be put somewhere so that it can be invoked by the \tr{#!} +script-invoking mechanism. (I believe \tr{/usr/bin/perl} is preferred; +we use \tr{/usr/local/bin/perl} at Glasgow.) The full pathname should +be less than 32 characters long. + +\item[GNU C (\tr{gcc}):] +\index{pre-supposed: GCC (GNU C compiler)} +\index{GCC (GNU C compiler), pre-supposed} +The current version is 2.7.2. It has a bug that it ticked if you +compile the @gmp@ library without the @-O@ flag. So the Makefile in +there has the @-O@ flag switched on! Otherwise, 2.7.2 has no problems that we know of. + +If your GCC dies with ``internal error'' on some GHC source file, +please let us know, so we can report it and get things improved. +(Exception: on \tr{iX86} boxes---you may need to fiddle with GHC's +\tr{-monly-N-regs} option; ask if confused...) + +\item[PVM version 3:] +\index{pre-supposed: PVM3 (Parallel Virtual Machine)} +\index{PVM3 (Parallel Virtual Machine), pre-supposed} +PVM is the Parallel Virtual Machine on which Parallel Haskell programs +run. (You only need this if you plan to run Parallel Haskell. +Concurent Haskell, which runs concurrent threads on a uniprocessor) +doesn't need it.) +Underneath PVM, you can have (for example) a network of +workstations (slow) or a multiprocessor box (faster). + +The current version of PVM is 3.3.11; we use 3.3.7. It is readily available on +the net; I think I got it from \tr{research.att.com}, in \tr{netlib}. + +A PVM installation is slightly quirky, but easy to do. Just follow +the \tr{Readme} instructions. + +\item[\tr{xargs} on Solaris2:] +\index{xargs, presupposed (Solaris only)} +\index{Solaris: alternative xargs} +The GHC libraries are put together with something like: +\begin{verbatim} +find bunch-of-dirs -name '*.o' -print | xargs ar q ... +\end{verbatim} +Unfortunately the Solaris \tr{xargs} (the shell-script equivalent +of \tr{map}) only ``bites off'' the \tr{.o} files a few at a +time---with near-infinite rebuilding of the symbol table in +the \tr{.a} file. + +The best solution is to install a sane \tr{xargs} from the GNU +findutils distribution. You can unpack, build, and install the GNU +version in the time the Solaris \tr{xargs} mangles just one GHC +library. + +\item[\tr{bash} (Parallel Haskell only):] +\index{bash, presupposed (Parallel Haskell only)} +Sadly, the \tr{gr2ps} script, used to convert ``parallelism profiles'' +to PostScript, is written in Bash (GNU's Bourne Again shell). +This bug will be fixed (someday). + +\item[Makeindex:] +\index{pre-supposed: makeindex} +\index{makeindex, pre-supposed} +You won't need this unless you are re-making our documents. Makeindex +normally comes with a \TeX{} distribution, but if not, we can provide +the latest and greatest. + +\item[Tgrind:] +\index{pre-supposed: tgrind} +\index{tgrind, pre-supposed} +This is required only if you remake lots of our documents {\em and} +you use the \tr{-t tgrind} option with \tr{lit2latex} (also literate +programming), to do ``fancy'' typesetting of your code. {\em +Unlikely.} + +\item[Flex:] +\index{pre-supposed: flex} +\index{flex, pre-supposed} +This is a quite-a-bit-better-than-Lex lexer. Used in the +literate-programming stuff. You won't need it unless you're hacking +on some of our more obscure stuff. + +\item[Yacc:] +\index{pre-supposed: non-worthless Yacc} +\index{Yacc, pre-supposed} +If you mess with the Haskell parser, you'll need a Yacc that can cope. +The unbundled \tr{/usr/lang/yacc} is OK; the GNU \tr{bison} is OK; +Berkeley yacc, \tr{byacc}, is not OK. + +\item[@sed@] +\index{pre-supposed: sed} +\index{sed, pre-supposed} +You need a working @sed@ if you are going to build from sources. +The build-configuration stuff needs it. +GNU sed version 2.0.4 is no good! It has a bug in it that is tickled by the +build-configuration. 2.0.5 is ok. Others are probably ok too +(assuming we don't create too elaborate configure scripts..) +\end{description} + +Two @fptools@ projects are worth a quick note at this point, because +they are useful for all the others: +\begin{itemize} +\item @glafp-utils@ contains several small utilities +which aren't particularly Glasgow-ish, but which are sometimes not +available on Unix systems. + +\item @literate@ contains the Glasgow-built tools for generating +documentation. (The unoriginal idea is to be able to generate @latex@, @info@, +and program code from a single source file.) To get anywhere you'll +need at least @lit2pgm@, either from the @literate@ project, or +because it's already installed on your system. +\end{itemize} + + + + +%************************************************************************ +%* * +\section{Building from source} +%* * +%************************************************************************ + +You've been rash enough to want to build some of +the Glasgow Functional Programming tools (GHC, Happy, +nofib, etc) from source. You've slurped the source, +from the CVS repository or from a source distribution, and +now you're sitting looking at a huge mound of bits, wondering +what to do next. + +Gingerly, you type @make all@. Wrong already! + +This rest of this guide is intended for duffers like me, who aren't really +interested in Makefiles and systems configurations, but who need +a mental model of the interlocking pieces so that they can +make them work, extend them consistently when adding new +software, and lay hands on them gently when they don't work. + +\subsection{Your source tree} + +The source code is held in your {\em source tree}. +The root directory of your source tree {\em must} +contain the following directories and files: +\begin{itemize} +\item @Makefile@: the root Makefile. +\item @mk/@: the directory that contains the +main Makefile code, shared by all the +@fptools@ software. +\item @configure.in@: a file that tells the GNU configuration +tools what @fptools@ needs to know about the host platform and +operating system. +\end{itemize} +All the other directories are individual {\em projects} of the +@fptools@ system --- for example, the Glasgow Haskell Compiler (@ghc@), +the Happy parser generator (@happy@), the @nofib@ benchmark stuite, +and so on. +You can have zero or more of these. Needless to say, some of them +are needed to build others. For example, you need @happy@ to build +@ghc@. You can either grab @happy@ too, or else you can use +an version of @happy@ that's already installed on your system, or +grab a binary distribution of @happy@ and install it. + +The important thing to remember is that even if you want only +one project (@happy@, say), you must have a source tree +whose root directory contains @Makefile@, +@mk/@, @configure.in@, and the project(s) you +want (@happy/@ in this case). You cannot get by with +just the @happy/@ directory. + +\subsection{Build trees} + +While you can build a system in the source tree, we don't recommend it. +We often want to build multiple versions of our software +for different architectures, or with different options (e.g. profiling). +It's very desirable to share a single copy of the source code among +all these builds. + +So for every source tree we have zero or more {\em build trees}. +Each build tree is initially an exact copy of the source tree, +except that each file is a symbolic link to the source file, +rather than being a copy of the source file. There are ``standard'' +Unix utilities that make such copies, so standard that they go by +different names: @lndir@, @mkshadowdir@ are two. + +The build +tree does not need to be anywhere near the source tree in the +file system. +Indeed, one advantage of separating the build tree from the source +is that the build tree can be placed in a non-backed-up partition, +saving your systems support people from backing up untold megabytes +of easily-regenerated, and rapidly-changing, gubbins. The golden rule is +that (with a single exception -- Section~\ref{sect_build-config}) +{\em absolutely +everything in the build tree is either a symbolic link to the source +tree, or else is mechanically generated}. It should be perfectly +OK for your build tree to vanish overnight; an hour or two compiling +and you're on the road again. + +You need to be a bit careful, though, that any new files you create +(if you do any development work) are in the source tree, not a build tree! + +Like the source tree, the top level of your build tree must (a linked copy of) +the root directory of the @fptools@ suite. +Inside Makefiles, the root of your build tree is called @$(FPTOOLS_TOP)@. +In the rest of this document path names are relative to @$(FPTOOLS_TOP)@ +unless otherwise stated. For example, the file @ghc/mk/target.mk@ is +actually @$(FPTOOLS_TOP)/ghc/mk/target.mk@. + + +\subsection{Getting the build you want} +\label{sect_build-config} + +When you build @fptools@ you will be compiling code +on a particular {\em host platform}, +to run on a particular {\em target platform} (usually the same +as the host platform)\index{platform}. The difficulty is +that there are minor differences between different platforms; +minor, but enough that the code needs to be a bit different +for each. There are some big differences too: for +a different architecture we need to build GHC with a different +native-code generator. + +There are also knobs you can turn to control how the @fptools@ +software is built. For example, you might want to build GHC +optimised (so that it runs fast) or unoptimised (so that you can +compile it fast after you've modified it. +Or, you might want to compile it with debugging on (so that +extra consistency-checking code gets included) or off. And so on. + +All of this stuff is called the {\em configuration} of your build. +You set the configuration using an exciting two-step process. +\begin{description} +\item[Step 1: system configuration.] This is easy, provided you +have the programs mentioned in Section~\ref{sect_std-utils}. Just +@cd@ to @$(FPTOOLS)@ and say @gmake configure@. This +command does three things: +\begin{itemize} +\item +It runs a GNU program called @autoconf@, which +converts @$(FPTOOLS)/configure.in@ to a shell script +called @$(FPTOOLS)/configure@. + +This step is completely platform-independent; it just means +that the human-written file (@configure.in@) can be short, although +the resulting shell script, @configure@ is long. + +\item It runs a second GNU program called @autoheader@, which converts +@$(FPTOOLS)/configure.in@ to @$(FPTOOLS)/mk/config.h.in@. +Again, this step is platform-independent. + +\item It then runs the newly-created @configure@ script. @configure@'s mission +is to scurry round your computer working out what architecture it has, +what operating system, whether it has the @vfork@ system call, +where @yacc@ is kept, whether @gcc@ is available, where various +obscure @#include@ files are, whether it's a leap year, and +what the systems manager had for lunch. +It communicates these snippets of information in two ways: +\begin{itemize} +\item It translates @mk/config.mk.in@ to @mk/config.mk@, +substituting for things between ``{\tt @@@@}'' brackets. So, +``{\tt @@HaveGcc@@}'' will be replaced by ``@YES@'' or ``@NO@'' +depending on what @configure@ finds. +@mk/config.mk@ is included by every Makefile (directly or indirectly), +so the configuration information is thereby communicated to +all Makefiles. + +\item It translates @mk/config.h.in@ to @mk/config.h@. +The latter is @#include@d by various C programs, which +can thereby make use of configuration information. +\end{itemize} +\end{itemize} + + +\item[Step 2: build configuration.] Next, you say how this build +of @fptools@ is to differ from the standard defaults by creating a new +file @mk/build.mk@ +{\em in the build tree}. This file is the one and only +file you edit in the build tree, precisely because it says how +this build differs from the source. (Just in case your build tree +does die, you might want to keep a private directory of @build.mk@ files, +and use a symbolic link in each build tree to point to the appropriate one.) +So @mk/build.mk@ never +exists in the source tree --- you create one in each build tree +from the template. We'll discuss what to put in it shortly. +\end{description} +And that's it for configuration. Simple, eh? + +What do you put in your build-specific configuration +file @mk/build.mk@? {\em For almost all purposes all you will do is +put make variable definitions that override those in @mk/config.mk.in@}. +The whole point of @mk/config.mk.in@ --- and its derived +counterpart @mk/config.mk@ --- is to define the build configuration. It is heavily +commented, as you will see if you look at it. +So generally, what you do is edit @mk/config.mk.in@ (read-only), and add definitions +in @mk/build.mk@ that override any of the @config.mk@ definitions that you +want to change. (The override occurs because the main boilerplate file, +@mk/boilerplate.mk@, includes @build.mk@ after @config.mk@.) + +For example, @config.mk.in@ contains the definition: +\begin{verbatim} + SUBDIRS = glafp-utils literate ghc +\end{verbatim} +The accompanying comment explains that this is the list of enabled +projects; that is, if (after configuring) you type @gmake all@ +in @FPTOOLS_TOP@ three specified projects will be made. +If you want to add @happy@, you can add this line to @build.mk@: +\begin{verbatim} + SUBDIRS += happy +\end{verbatim} +or, if you prefer, +\begin{verbatim} + SUBDIRS = glafp-utils literate ghc happy +\end{verbatim} +(GNU @make@ allows existing definitions to have new text appended using +the ``@+=@'' operator, which is quite a convenient feature.) + +When reading @config.mk.in@, remember that anything between ``{\tt @@...@@}'' signs +is going to be substituted by @configure@ later. You {\em can} override +the resulting definition if you want, +but you need to be a bit surer what you are doing. +For example, there's a line that says: +\begin{verbatim} + YACC = @Yacc@ +\end{verbatim} +This defines the Make variables @YACC@ to the pathname for a Yacc that +@configure@ finds somewhere. If you have your own pet Yacc you want +to use instead, that's fine. Just add this line to @mk/build.mk@: +\begin{verbatim} + YACC = myyacc +\end{verbatim} +You do not {\em have} to have a @mk/build.mk@ file at all; if you don't, +you'll get all the default settings from @mk/config.mk.in@. + + +\subsection{The story so far} + +Let's summarise the steps you need to carry to get yourself +a fully-configured build tree from scratch. + +\begin{enumerate} +\item Get your source tree from somewhere (CVS repository or +source distribution). Say you call the root directory +@myfptools@ (it does not have to be called @fptools@). + +\item Use @lndir@ or @mkshadowdir@ to create a build tree. +\begin{verbatim} + cd myfptools + mkshadowdir . /scratch/joe-bloggs/myfptools-sun4 +\end{verbatim} +You probably want to give the build tree a name that +suggests its main defining characteristic (in your mind at least), +in case you later add others. + +\item Change directory to the build tree. Everything is going +to happen there now. +\begin{verbatim} + cd /scratch/joe-bloggs/myfptools-sun4 +\end{verbatim} +\item Do system configuration: +\begin{verbatim} + gmake configure +\end{verbatim} +\item Create the file @mk/build.mk@, +adding definitions for your desired configuration options. +\begin{verbatim} + emacs mk/build.mk +\end{verbatim} +\end{enumerate} +You can make subsequent changes to @mk/build.mk@ as often +as you like. You do not have to run any further configuration +programs to make these changes take effect. +In theory you should, however, say @gmake clean@, @gmake all@, +because configuration option changes could affect anything --- but in practice you are likely to know what's affected. + +\subsection{Making things} + +At this point you have made yourself a fully-configured build tree, +so you are ready to start building real things. + +The first thing you need to know is that +{\em you must use GNU @make@, usually called @gmake@, not standard Unix @make@}. +If you use standard Unix @make@ you will get all sorts of error messages +(but no damage) because the @fptools@ @Makefiles@ use GNU @make@'s facilities +extensively. + +\subsection[sect_standard-targets]{Standard targets} + +In any directory you should be able to make the following: +\begin{description} +\item[@boot@:] does the one-off preparation required to get ready +for the real work. Notably, it does @gmake depend@ in all directories +that contain programs. But @boot@ does more. For example, you can't +do @gmake depend@ in a directory of C program until you have converted +the literate @.lh@ header files into standard @.h@ header files. Similarly, you convert a literate file to illiterate +form until you have built the @literate@ tools. @boot@ takes care of these +inter-directory dependencies. + +You should say @gmake boot@ right after configuring your build tree. + +\item[@all@:] makes all the final target(s) for this Makefile. +Depending on which directory you are in a ``final target'' +may be an executable program, a library archive, a shell script, +or a Postscript file. +Typing @gmake@ alone is generally the same as typing @gmake all@. + +\item[@install@:] installs the things built by @all@. Where does it +install them? That is specified by @mk/config.mk.in@; you can +override it in @mk/build.mk@. + +\item[@uninstall@:] reverses the effect of @install@. + +\item[@clean@:] remove all easily-rebuilt files. + +\item[@veryclean@:] remove all files that can be rebuilt at all. +There's a danger here that you may remove a file that needs a more +obscure +utility to rebuild it (especially if you started from a source +distribution). + +\item[@check@:] run the test suite. +\end{description} +All of these standard targets +automatically recurse into sub-directories. +Certain other standard targets do not: +\begin{description} +\item[@configure@:] is only available in the root directory @$(FPTOOLS)@; +it has been discussed in Section~\ref{sect_build-config}. + +\item[@depend@:] make a @.depend@ file in each directory that needs +it. This @.depend@ file contains mechanically-generated dependency +information; for example, suppose a directory contains a Haskell +source module @Foo.lhs@ which imports another module @Baz@. +Then the generated @.depend@ file will contain the dependency: +\begin{verbatim} + Foo.o : Baz.hi +\end{verbatim} +which says that the object file @Foo.o@ depends on the interface +file @Baz.hi@ generated by compiling module @Baz@. +The @.depend@ file is automatically included by every Makefile. + +\item[@binary-dist@:] make a binary distribution. + +\item[@dist@:] make a source distribution. +\end{description} + +\subsection{Other targets} + +Most @Makefiles@ have targets other than these. You can find +this out by looking in the @Makefile@ itself. + + + + +%************************************************************************ +%* * +\section{The @Makefile@ architecture} +%* * +%************************************************************************ + + +@make@ is great if everything works --- you type @gmake install@ and, lo, +the right things get compiled and installed in the right places. +Our goal is to make this happen often, but somehow it often doesn't; +instead +some wierd error message eventually emerges from the bowels of a directory +you didn't know existed. + +The purpose of this section is to give you a road-map to help you figure +out what is going right and what is going wrong. + +\subsection{A small project} + +To get started, let us look at the @Makefile@ for an imaginary small +@fptools@ project, @small@. Each project in @fptools@ has its own +directory in @FPTOOLS_TOP@, so the @small@ project will have its own +directory @FPOOLS_TOP/small/@. Inside the @small/@ directory there +will be a @Makefile@, looking something like this: +\begin{verbatim} + # Makefile for fptools project "small" + + TOP = .. + include $(TOP)/mk/boilerplate.mk + + SRCS = $(wildcard *.lhs) $(wildcard *.c) + HS_PROG = small + + include $(TOP)/target.mk +\end{verbatim} +This @Makefile@ has three sections: +\begin{enumerate} +\item The first section includes\footnote{One of the +most important features of GNU @make@ that we use is the ability +for a @Makefile@ to include another named file, very like @cpp@'s @#include@ directive.} +a file of ``boilerplate'' code from the +level above (which in this case will be @FPTOOLS_TOP/mk/boilerplate.mk@). +As its name suggests, @boilerplate.mk@ consists of a large quantity of standard +@Makefile@ code. We discuss this boilerplate in more detail in Section~\ref{sect_boiler}. + +Before the @include@ statement, you must define the @make@ variable +@TOP@ to be the directory containing the @mk@ directory in which +the @boilerplate.mk@ file is. +It is {\em not} OK to simply say +\begin{verbatim} + include ../mk/boilerplate.mk # NO NO NO +\end{verbatim} +Why? Because the @boilerplate.mk@ file needs to know where it is, +so that it can, in turn, @include@ other files. +(Unfortunately, when an @include@d file does an +@include@, the filename is treated +relative to the directory in which @gmake@ is being run, not +the directory in which the @included@ sits.) +In general, +{\em every file @foo.mk@ +assumes that @$(TOP)/mk/foo.mk@ refers to itself.} +It is up to the @Makefile@ doing the @include@ to ensure this +is the case. + +Files intended for inclusion in other @Makefile@s are written to have +the following property: +{\em after @foo.mk@ is @include@d, it leaves @TOP@ containing the same +value as it had just before the @include@ statement}. +In our example, this invariant guarantees that the @include@ +for @target.mk@ will look in the same directory as that for +@boilerplate.mk@. + +\item The second section +defines the following standard @make@ variables: @SRCS@ (the source files from +which is to be built), and @HS_PROG@ (the +executable binary to be built). +We will discuss in more detail what the ``standard variables'' are, +and how they affect what happens, in Section~\ref{sect_targets}. + +The definition for @SRCS@ uses the useful GNU @make@ +construct @$(wildcard@~$pat$@)@, which expands to a list of all the +files matching the pattern $pat$ in the current directory. +In this example, @SRCS@ is set to the list of all the @.lhs@ and @.c@ files +in the directory. (Let's suppose there is one of each, @Foo.lhs@ +and @Baz.c@.) + +\item The last section includes a second file of standard code, +called @target.mk@. It contains the rules that tell @gmake@ +how to make the standard targets +(Section~\ref{sect_standard-targets}). +Why, you ask, can't this standard code +be part of @boilerplate.mk@? Good question. +We discuss the reason later, in Section~\ref{sect_boiler-arch}. + +You do not {\em have} to @include@ the @target.mk@ file. Instead, +you can write rules of your own for all the standard targets. +Usually, though, you will find quite a big payoff from using +the canned rules in +@target.mk@; the price tag is that you have to understand +what canned rules get enabled, and what they do (Section~\ref{sect_targets}). +\end{enumerate} + +In our example @Makefile@, most of the work is done +by the two @include@d files. When you say @gmake all@, +the following things happen: +\begin{itemize} +\item @gmake@ figures out that the object files are @Foo.o@ and @Baz.o@. +\item It uses a boilerplate pattern rule to compile +@Foo.lhs@ to @Foo.o@ using +a Haskell compiler. (Which one? That is set in the build configuration.) +\item It uses another standard pattern rule to compile @Baz.c@ to @Baz.o@, +using a C compiler. (Ditto.) +\item It links the resulting @.o@ files together to make @small@, +using the Haskell compiler to do the link step. (Why not use @ld@? Because +the Haskell compiler knows what standard librarise to link in. How did @gmake@ +know to use the Haskell compiler to do the link, rather than the C compiler? +Because we set the variable @HS_PROG@ rather than @C_PROG@.) +\end{itemize} +All @Makefile@s should follow the above three-section format. + +\subsection{A larger project} + +Larger projects are usually structured into a nummber of sub-directories, +each of which has its own @Makefile@. (In very large projects, this +sub-structure might be iterated recursively, though that is rare.) +To give you the idea, here's part of the directory structure for +the (rather large) @ghc@ project: +\begin{verbatim} + $(FPTOOLS_TOP)/ghc/ + Makefile + + mk/ + boilerplate.mk + rules.mk + + docs/ + Makefile + ...source files for documentation... + + driver/ + Makefile + ...source files for driver... + + compiler/ + Makefile + parser/...source files for parser... + renamer/...source files for renamer... + ...etc... +\end{verbatim} +The sub-directories @docs@, @driver@, @compiler@, and so on, each contains +a sub-component of @ghc@, and each has its own @Makefile@. +There must also be a @Makefile@ in @$(FPTOOLS_TOP)/ghc@. +It does most of its work by recursively invoking @gmake@ +on the @Makefile@s in the sub-directories. +We say that @ghc/Makefile@ is a {\em non-leaf @Makefile@}, +because it does little except organise its children, while the @Makefile@s +in the sub-directories are all {\em leaf @Makefile@s}. (In principle +the sub-directories might themselves contain a non-leaf @Makefile@ and +several sub-sub-directories, but that does not happen in @ghc@.) + +The @Makefile@ in @ghc/compiler@ is considered a leaf @Makefile@ even +though the @ghc/compiler@ has sub-directories, because these sub-directories +do not themselves have @Makefile@ in them. They are just used to structure +the collection of modules that make up @ghc@, but all are managed by the +single @Makefile@ in @ghc/compiler@. + +You will notice that @ghc/@ also contains a directory @ghc/mk/@. +It contains @ghc@-specific @Makefile@ boilerplate code. +More precisely: +\begin{itemize} +\item @ghc/mk/boilerplate.mk@ is included at the top of @ghc/Makefile@, +and of all the leaf @Makefile@s in the sub-directories. +It in turn @include@s the main boilerplate file @mk/boilerplate.mk@. + +\item @ghc/mk/target.mk@ is @include@d at the bottom of @ghc/Makefile@, +and of all the leaf @Makefiles@ in the sub-directories. +It in turn @include@s the file @mk/target.mk@. +\end{itemize} +So these two files are the place to look for @ghc@-wide customisation +of the standard boilerplate. + + + +\subsection{Boilerplate architecture} +\label{sect_boiler-arch} + +Every @Makefile@ includes a @boilerplate.mk@ file at the top, +and @target.mk@ file at the bottom. In this section we discuss +what is in these files, and why there have to be two of them. +In general: +\begin{itemize} +\item @boilerplate.mk@ consists of: +\begin{itemize} +\item {\em Definitions of millions of @make@ variables} that collectively +specify the build configuration. Examples: @HC_OPTS@, the options to +feed to the Haskell compiler; @NoFibSubDirs@, the sub-directories to +enable within the @nofib@ project; @GhcWithHc@, the name of the +Haskell compiler to use when compiling @GHC@ in the @ghc@ project. +\item {\em Standard pattern rules} that tell @gmake@ how to construct +one file from another. +\end{itemize} +@boilerplate.mk@ needs to be @include@d at the {\em top} of each +@Makefile@, so that the +user can replace the boilerplate definitions or pattern rules by simply +giving a new definition or pattern rule in the @Makefile@. @gmake@ simply +takes the last definition as the definitive one. + +Instead of {\em replacing} boilerplate definitions, it is also quite +common to {\em augment} them. For example, a @Makefile@ might say: +\begin{verbatim} + SRC_HC_OPTS += -O +\end{verbatim} +thereby adding ``@-O@'' to the end of @SRC_HC_OPTS@. + +\item @target.mk@ contains @make@ rules for the standard targets described +in Section~\ref{sect_standard-targets}. +These rules are selectively included, depending on the setting of +certain @make@ variables. These variables are usually set in the middle +section of the @Makefile@ between the two @include@s. + +@target.mk@ must be included at the end (rather than being part of @boilerplate.mk@) +for several tiresome reasons: +\begin{itemize} +\item @gmake@ commits target and dependency lists earlier than it should. +For example, @target.mk@ has a rule that looks like this: +\begin{verbatim} + $(HS_PROG) : $(OBJS) + $(HC) $(LD_OPTS) $< -o $@ +\end{verbatim} +If this rule was in @boilerplate.mk@ then @$(HS_PROG)@ and @$(OBJS)@ +would not have their final values at the moment @gmake@ encountered the +rule. Alas, @gmake@ takes a snapshot of their current values, and +wires that snapshot into the rule. +(In contrast, the commands executed when the rule ``fires'' are +only substituted at the moment of firing.) +So, the rule must follow the definitions given in the @Makefile@ itself. + +\item Unlike pattern rules, ordinary rules cannot be overriden or +replaced by subsequent rules for the same target (at least not without an +error message). Including ordinary rules in @boilerplate.mk@ would +prevent the user from writing rules for specific targets in specific cases. + +\item There are a couple of other reasons I've forgotten, but it doesn't +matter too much. +\end{itemize} +\end{itemize} + +\subsection{The main @mk/boilerplate.mk@ file} +\label{sect_boiler} + +If you look at @$(FPTOOLS_TOP)/mk/boilerplate.mk@ you will find that +it consists of the following sections, each held in a separate file: +\begin{description} +\item[@config.mk@] is the build configuration file we discussed at length +in Section~\ref{sect_build-config}. + +\item[@paths.mk@] defines @make@ variables for pathnames and file +lists. In particular, it gives definitions for: +\begin{description} +\item[@SRCS@:] all source files in the current directory. +\item[@HS_SRCS@:] all Haskell source files in the current directory. +It is derived from @$(SRCS)@, so if you override @SRCS@ with a new value +@HS_SRCS@ will follow suit. +\item[@C_SRCS@:] similarly for C source files. +\item[@HS_OBJS@:] the @.o@ files derived from @$(HS_SRCS)@. +\item[@C_OBJS@:] similarly for @$(C_SRCS)@. +\item[@OBJS@:] the concatenation of @$(HS_OBJS)@ and @$(C_OBJS)@. +\end{description} +Any or all of these definitions can easily be overriden by giving new +definitions in your @Makefile@. For example, +if there are things in the current directory that look like source files +but aren't, then you'll need to set @SRCS@ manually in your @Makefile@. +The other definitions will then work from this new definition. + +What, exactly, does @paths.mk@ consider a ``source file'' to be. +It's based the file's suffix (e.g. @.hs@, @.lhs@, @.c@, @.lc@, etc), +but this is the kind of detail that changes +more rapidly, so rather than enumerate the source suffices here the best thing +to do is to look in @paths.mk@. + +\item[@opts.mk@] defines @make@ variables for option strings to +pass to each program. For example, it defines @HC_OPTS@, the +option strings to pass to the Haskell compiler. See \sectionref{sect_suffix}. + +\item[@suffix.mk@] defines standard pattern rules -- see \sectionref{sect_suffix} +\end{description} +Any of the variables and pattern rules defined by the boilerplate file +can easily be overridden in any particular @Makefile@, because +the boilerplace @include@ comes first. Definitions after this +@include@ directive simply override the default ones in @boilerplate.mk@. + +\subsection[sect_suffix]{Pattern rules and options} + +The file @suffix.mk@ defines standard {\em pattern rules} that say how to build one kind +of file from another, for example, how to build a @.o@ file from a @.c@ file. +(GNU @make@'s {\em pattern rules} are more powerful and easier to use than +Unix @make@'s {\em suffix rules}.) + +Almost all the rules look something like this: +\begin{verbatim} +%.o : %.c + @$(RM) $@ + $(CC) $(CC_OPTS) -c $< -o $@ +\end{verbatim} +Here's how to understand the rule. It says that $something@.o@$ (say @Foo.o@) +can be built from $something@.c@$ (@Foo.c@), by invoking the C compiler +(path name held in @$(CC)@), passing to it the options @$(CC_OPTS)@ and the rule's +dependent +file of the rule @$<@ (@Foo.c@ in this case), and putting the result in +the rule's target @$@@@ (@Foo.o@ in this case). + +Every program is held in a @make@ variable defined in @mk/config.mk@ --- look in @mk/config.mk@ for +the complete list. One important one is the Haskell compiler, which is called @$(HC)@. + +Every programs options are are held in a @make@ variables called @<prog>_OPTS@. +the @<prog>_OPTS@ variables are defined in @mk/opts.mk@. Almost all of them are defined +like this: +\begin{verbatim} + CC_OPTS = $(SRC_CC_OPTS) $(WAY$(_way)_CC_OPTS) $($*_CC_OPTS) $(EXTRA_CC_OPTS) +\end{verbatim} +The four variables from which @CC_OPTS@ is built have the following meaning: +\begin{description} +\item[@SRC_CC_OPTS@:] options passed to all C compilations. +\item[@WAY_<way>_CC_OPTS@:] options passed to C compilations for way @<way>@. For example, +@WAY_mp_CC_OPTS@ gives options to pass to the C compiler when compiling way @mp@. +The variable @WAY_CC_OPTS@ holds options to pass to the C compiler when compiling the standard way. +(Section~\ref{sect_ways} dicusses multi-way compilation.) +\item[@<module>_CC_OPTS@:] options to pass to the C compiler that are specific to module @<module>@. +For example, @SMap_CC_OPTS@ gives the specific options to pass to the C compiler when compiling +@SMap.c@. +\item[@EXTRA_CC_OPTS@:] extra options to pass to all C compilations. This is intended for command +line use, thus; +\begin{verbatim} + gmake libHS.a EXTRA_CC_OPTS="-v" +\end{verbatim} +\end{description} + + +\subsection{The main @mk/target.mk@ file} +\label{sect_targets} + +@target.mk@ contains canned rules for all the standard targets described in +Section~\ref{sect_standard-targets}. It is complicated by the fact +that you don't want all of these rules to be active in every @Makefile@. +Rather than have a plethora of tiny files which you can include selectively, +there is a single file, @target.mk@, which selectively includes rules +based on whether you have defined certain variables in your @Makefile@. +This section explains what rules you get, what variables control them, and +what the rules do. Hopefully, you will also get enough of an idea of what is supposed +to happen that you can read and understand any wierd special cases yourself. + +\begin{description} +\item{@HS_PROG@.} If @HS_PROG@ is defined, you get rules with the +following targets: +\begin{description} +\item[@HS_PROG@] itself. This rule links @$(OBJS)@ with the Haskell +runtime system to get an executable called @$(HS_PROG)@. +\item[@install@] installs @$(HS_PROG)@ in @$(bindir)@ with the execute bit set. +\end{description} + +\item[@C_PROG@] is similar to @HS_PROG@, except that the link step +links @$(C_OBJS)@ with the C runtime system. + +\item[@LIBRARY@] is similar to @HS_PROG@, except +that it links @$(LIB_OBJS)@ to make the library archive @$(LIBRARY)@, +and @install@ installs it in @$(libdir)@, with the execute bit not set. + +\item[@LIB_DATA@] ... +\item[@LIB_EXEC@] ... + +\item[@HS_SRCS@, @C_SRCS@.] If @HS_SRCS@ is defined and non-empty, a rule for +the target @depend@ is included, which generates dependency information for +Haskell programs. Similarly for @C_SRCS@. +\end{description} + +All of these rules are ``double-colon'' rules, thus +\begin{verbatim} + install :: $(HS_PROG) + ...how to install it... +\end{verbatim} +GNU @make@ treats double-colon rules as separate entities. If there +are several double-colon rules for the same target it takes each in turn +and fires it if its dependencies say to do so. This means that you can, +for example, define both @HS_PROG@ and @LIBRARY@, which will generate two +rules for @install@. When you type @gmake install@ both rules will be fired, +and both the program and the library will be installed, just as you wanted. + +\subsection{Recursion} +\label{sect_subdirs} + +In leaf @Makefiles@ the variable @SUBDIRS@ is undefined. In non-leaf +@Makefiles@, @SUBDIRS@ is set to the list of sub-directories that contain subordinate +@Makefile@s. {\em It is up to you to set @SUBDIRS@ in the @Makefile@.} +There is no automation here --- @SUBDIRS@ is too important automate. + +When @SUBDIRS@ is defined, @target.mk@ includes a rather neat rule for +the standard targets (Section~\ref{sect_standard-targets}) that +simply invokes @make@ recursively in each of the sub-directories. + +{\em These recursive invocations are guaranteed to occur in the order in +which the list of directories is specified in @SUBDIRS@.} This guarantee can +be important. For example, when you say @gmake boot@ it can be important +that the recursive invocation of @make boot@ is done in one sub-directory (the include +files, say) before another (the source files). +Generally, put the most independent sub-directory first, and the most dependent +last. + +\subsection{Way management} +\label{sect_ways} + +We sometimes want to build essentially the same system in several different +``ways''. For example, we want to build @ghc@'s @Prelude@ libraries with +and without profiling, with and without concurrency, and so on, so that +there is an appropriately-built library archive to link with when the user compiles +his program. +It would be possible to have a completely separate build tree for each such ``way'', +but it would be horribly bureaucratic, especially since often only parts of the +build tree need to be constructed in multiple ways. + +Instead, the @template.mk@ contains some clever magic to allow you to build +several versions of a system; and to control locally how many versions are built +and how they differ. This section explains the magic. + +The files for a particular way are distinguished by munging the suffix. +The ``normal way'' is always built, and its files have the standard suffices +@.o@, @.hi@, and so on. In addition, you can build one or more extra ways, +each distinguished by a {\em way tag}. The object files and interface files +for one of these extra ways are distinguished by their suffix. For example, +way @mp@ has files @.mp_o@ and @.mp_hi@. Library archives have their way +tag the other side of the dot, for boring reasons; thus, @libHS_mp.a@. + +A @make@ variable called @way@ holds the current way tag. {\em @way@ is only ever +set on the command line of a recursive invocation of @gmake@.} It is +never set inside a @Makefile@. So it is a global constant for any one invocation +of @gmake@. Two other @make@ variables, @way_@ and @_way@ are immediately derived +from @$(way)@ and never altered. If @way@ is not set, then neither are @way_@ +and @_way@, and the invocation of @make@ will build the ``normal way''. +If @way@ is set, then the other two variables are set in sympathy. +For example, if @$(way)@ is ``@mp@'', then @way_@ is set to ``@mp_@'' +and @_way@ is set to ``@_mp@''. These three variables are then used +when constructing file names. + +So how does @make@ ever get recursively invoked with @way@ set? There +are two ways in which this happens: +\begin{itemize} +\item For some (but not all) of the standard targets, when in a leaf sub-directory, +@make@ is recursively invoked for each way tag in @$(WAYS)@. You set @WAYS@ to +the list of way tags you want these targets built for. The mechanism here is +very much like the recursive invocation of @make@ in sub-directories +(Section~\ref{sect_subdirs}). + +It is up to you to set @WAYS@ in your @Makefile@; this is how you control +what ways will get built. +\item For a useful collection of targets (such as @libHS_mp.a@, @Foo.mp_o@) +there is a rule which recursively invokes @make@ to make the specified +target, setting the @way@ variable. So if you say @gmake Foo.mp_o@ +you should see a recursive invocation @gmake Foo.mp_o way=mp@, +and {\em in this recursive invocation the pattern rule for compiling a Haskell +file into a @.o@ file will match}. The key pattern rules (in @suffix.mk@) +look like this: +\begin{verbatim} + %.$(way_)o : %.lhs + $(HC) $(HC_OPTS) $< -o $@ +\end{verbatim} +Neat, eh? +\end{itemize} + + +\subsection{When the canned rule isn't right} + +Sometimes the canned rule just doesn't do the right thing. For example, in +the @nofib@ suite we want the link step to print out timing information. +The thing to do here is {\em not} to define @HS_PROG@ or @C_PROG@, and instead +define a special purpose rule in your own @Makefile@. +By using different variable names you will avoid the canned rules being included, +and conflicting with yours. + + +%************************************************************************ +%* * +\section[booting-from-C]{Booting/porting from C (\tr{.hc}) files} +\index{building GHC from .hc files} +\index{booting GHC from .hc files} +%* * +%************************************************************************ + +This section is for people trying to get GHC going by using the +supplied intermediate C (\tr{.hc}) files. This would probably be +because no binaries have been provided, or because the machine +is not ``fully supported.'' + +THIS SECTION HASN'T BEEN UPDATED YET. Please let us know if you want to use this +route. Unless someone does, this section may never get written, and the +.hc files distribution may not get built! + + +%************************************************************************ +%* * +\section[build-pitfalls]{Known pitfalls in building Glasgow Haskell} +\index{problems, building} +\index{pitfalls, in building} +\index{building pitfalls} +%* * +%************************************************************************ + +WARNINGS about pitfalls and known ``problems'': + +\begin{enumerate} +%------------------------------------------------------------------------ +\item +One difficulty that comes up from time to time is running out of space +in \tr{/tmp}. (It is impossible for the configuration stuff to +compensate for the vagaries of different sysadmin approaches re temp +space.) + +The quickest way around it is \tr{setenv TMPDIR /usr/tmp} or +even \tr{setenv TMPDIR .} (or the equivalent incantation with the +shell of your choice). + +The best way around it is to say +\begin{verbatim} + TMPDIR=<dir> +\end{verbatim} +in your @build.mk@ file. +Then GHC and the other @fptools@ programs will use the appropriate directory +in all cases. + +%------------------------------------------------------------------------ +\item +In compiling some support-code bits, e.g., in \tr{ghc/runtime/gmp} and +even in \tr{ghc/lib}, you may get a few C-compiler warnings. We think +these are OK. + +%------------------------------------------------------------------------ +\item +When compiling via C, you'll sometimes get ``warning: +assignment from incompatible pointer type'' out of GCC. Harmless. + +%------------------------------------------------------------------------ +\item +Similarly, \tr{ar}chiving warning messages like the following are not +a problem: +\begin{verbatim} +ar: filename GlaIOMonad__1_2s.o truncated to GlaIOMonad_ +ar: filename GlaIOMonad__2_2s.o truncated to GlaIOMonad_ +... +\end{verbatim} + +%------------------------------------------------------------------------ +\item +Also harmless are some specialisation messages that you may see when +compiling GHC; e.g.: +\begin{verbatim} +SPECIALISATION MESSAGES (Desirable): +*** INSTANCES +{-# SPECIALIZE instance Eq [Class] #-} +{-# SPECIALIZE instance Eq (Class, [Class]) #-} +{-# SPECIALIZE instance Outputable [ClassOp] #-} +{-# SPECIALIZE instance Outputable [Id] #-} +\end{verbatim} + +%------------------------------------------------------------------------ +\item +In compiling the compiler proper (in \tr{compiler/}), you {\em may} get an +``Out of heap space'' error message. These +can vary with the vagaries of different systems, it seems. The +solution is simple: (1)~add a suitable \tr{-H} flag to the @<module>_HC_OPTS@ +@make@ variable in the appropriate @Makefile@; +(2)~try again: \tr{gmake}. +(Section~\ref{sect_suffix}.) + +Alternatively, just cut to the chase scene: +\begin{verbatim} +% cd ghc/compiler +% make EXTRA_HC_OPTS=-H32m # or some nice big number +\end{verbatim} + +%------------------------------------------------------------------------ +\item +Not too long into the build process, you may get a huge complaint +of the form: +\begin{verbatim} +Giant error 'do'ing getopts.pl: at ./lit2pgm.BOOT line 27. +\end{verbatim} +This indicates that your \tr{perl} was mis-installed; the binary is +unable to find the files for its ``built-in'' library. Speak to your +perl installer, then re-try. + +%------------------------------------------------------------------------ +\item +If you try to compile some Haskell, and you get errors from GCC +about lots of things from \tr{/usr/include/math.h}, then your GCC +was mis-installed. \tr{fixincludes} wasn't run when it should've +been. + +As \tr{fixincludes} is now automagically run as part of GCC +installation, this bug also suggests that you have an old GCC. + + +%------------------------------------------------------------------------ +\item +You {\em may} need to re-\tr{ranlib} your libraries (on Sun4s). +\begin{verbatim} +% cd $(libdir)/ghc-2.01/sparc-sun-sunos4 +% foreach i ( `find . -name '*.a' -print` ) # or other-shell equiv... +? ranlib $i +? # or, on some machines: ar s $i +? end +\end{verbatim} +We'd be interested to know if this is still necessary. + +%------------------------------------------------------------------------ +\item +If you end up making documents that involve (La)TeX and/or \tr{tib} +(Simon's favourite), the odds are that something about your/our setup +will reach out and bite you. Yes, please complain; meanwhile, +you can do \tr{make -n whatever.dvi} to see the intended commands, +then try to muddle through, doing them by hand. + +\end{enumerate} + + + +% ==================================================================== +Here follow pitfalls that apply to pre-2.02 releases. They should not +happen any more If they do crop up with 2.02 or later, please let us +know. + +\begin{enumerate} +%------------------------------------------------------------------------ +\item +When configuring the support code (mkworld, glafp-utils, etc.), you +will see mention of \tr{NO_SPECIFIC_PROJECT} and +\tr{NO_SPECIFIC_VERSION}. This is cool. + + +%------------------------------------------------------------------------ +\item +Sooner or later in your ``make-worlding'' life you will do and see +something like: +\begin{verbatim} +% make Makefile + rm -f Makefile.bak; mv Makefile Makefile.bak +../.././mkworld/jmake -P ghc -S std -I../.././mkworld -DTopDir=../../. -DTopDir=... +../.././mkworld/jrestoredeps +==== The new Makefile is for: ==== +make: Fatal error in reader: Makefile, line 850: Unexpected end of line seen +Current working directory /export/users/fp/grasp/ghc-0.26/ghc/runtimes/standard +*** Error code 1 +make: Fatal error: Command failed for target `Makefile' +\end{verbatim} + +Don't panic! It should restore your previous \tr{Makefile}, and +leave the junk one in \tr{Makefile.bad}. Snoop around at your leisure. + +% ------------------------------------------------------------------------ +\item +If you do corrupt a \tr{Makefile} totally, or you need to glue a new +directory into the directory structure (in \tr{newdir}---which must +have a \tr{Jmakefile}, even if empty), here's a neat trick: +\begin{verbatim} +# +# move to the directory just above the one where you want a Makefile... +cd .. +# +# make Makefiles, but lie about the directories below... +make Makefiles SUBDIRS=newdir +\end{verbatim} + +This will create a \tr{Makefile} {\em ex nihilo} in \tr{newdir}, and +it will be properly wired into the general make-world structure. + +% ------------------------------------------------------------------------ +\item +Don't configure/build/install using a variety of machines. A +mistake we've made is to do \tr{make Makefiles} on a Sun4, then try to +build GHC (\tr{make all}) on a Sun3. + +%------------------------------------------------------------------------ +%\item +%If you build an ``unregisterised'' build, you will get bazillions of +%warnings about `ANSI C forbids braced-groups within expressions'. +%Especially in \tr{ghc/lib}. These are OK. + +\end{enumerate} + + +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} + diff --git a/ghc/CONTRIB/README b/ghc/CONTRIB/README deleted file mode 100644 index 79aca73692..0000000000 --- a/ghc/CONTRIB/README +++ /dev/null @@ -1,19 +0,0 @@ -This directory contains contributed software/bits related to the -Glasgow Haskell compiler. - -fptags Denis Howe <dbh@doc.ic.ac.uk> - Bourne-shell script. - Create an emacs TAGS file for one or more functional programs. - -haskell-modes/ A collection of all known "Haskell modes" for GNU Emacs. - -haskel.gif Provided by Lennart Augustsson <augustss@cs.chalmers.se> - -haskell_poem Speaks for itself. - -mira2hs Denis Howe <dbh@doc.ic.ac.uk> - Bourne-shell script. - Convert Miranda code to Haskell, more-or-less. - -pphs Pretty-print Haskell code in LaTeX documents. Written by - Andrew Preece while a student at Glasgow. diff --git a/ghc/CONTRIB/fptags b/ghc/CONTRIB/fptags deleted file mode 100644 index be4b5a5c30..0000000000 --- a/ghc/CONTRIB/fptags +++ /dev/null @@ -1,53 +0,0 @@ -#!/bin/sh - -#fptags - Create an emacs tags file for functional programs - -#Please send me a copy of any modifications you make. -#Denis Howe <dbh@doc.ic.ac.uk> -#0.00 20-Sep-1991 created -#0.01 09-Apr-1992 don't count ==, <=, >= as definition -#0.02 09-Feb-1994 fix bug in fix 0.01. Add /=. - -# partain: got it from wombat.doc.ic.ac.uk:pub - -#The algorithm for spotting identifiers is crude to the point of -#vulgarity. Any line containing an = is assumed to define an -#identifier. If there are no non-white characters before the = then -#the definition is assumed to start on the previous line. White -#characters are space, tab and > (for literate programs). The =s in -#the relations ==, <=, >= and /= are temporarily transformed while -#searching for =s. - -#The tags file is not in the format produced by ctags but rather, -#that produced by etags and used by GNU-Emacs's find-tag command. - -#Does not tag constructors in sum data types. - -#The tags file, TAGS, is created in the current directory. It -#contains an entry for each argument file. The entry begins with a -#line containing just ^L. The next line contains the filename, a -#comma and the number of following bytes before the next ^L or EOF. -#Subsequent lines should give the location within the argument file of -#identifier definitions. Each line contains a prefix of a line from -#the argument file, a ^?, the line number within the argument file, a -#comma and the position of the start of that line in the argument file -#(first character = 1). - -[ -z "$1" ] && echo usage: $0 files && exit 1 -exec > TAGS -tf=/tmp/fp$$ -for f -do echo " " - sed 's/==/ /g - s/>=/> /g - s/<=/< /g - s|/=|/ |g' $f | awk ' - /^[> ]*=/{ print prevline "" NR-1 "," prevpos; } - /[^> ].*=/{ print $0 "" NR "," pos; } - { prevline = $0; prevpos = pos; pos += length($0)+1; } - ' pos=1 | sed 's/[ )]*=.*// - s/ /=/g' > $tf - echo -n $f,; echo `wc -c < $tf` #lose spaces - cat $tf -done -rm -f $tf diff --git a/ghc/CONTRIB/haskel.gif b/ghc/CONTRIB/haskel.gif Binary files differdeleted file mode 100644 index 89b20abefc..0000000000 --- a/ghc/CONTRIB/haskel.gif +++ /dev/null diff --git a/ghc/CONTRIB/haskell-modes/README b/ghc/CONTRIB/haskell-modes/README deleted file mode 100644 index c931787996..0000000000 --- a/ghc/CONTRIB/haskell-modes/README +++ /dev/null @@ -1,55 +0,0 @@ -I've collected all the Haskell modes for GNU Emacs that I could lay my -hands on -- there are billions. A list is attached, grouped by -"family". - -I don't like "mode junk" myself, so I don't use any of them. I will -include advertising or testimonials from happy users if they send them -along... - -Will Partain -partain@dcs.gla.ac.uk -95/12/05 - -======================================================================= - -* "Chalmers Haskell mode family" -- "Major mode for editing Haskell", - by Lars Bo Nielsen and Lennart Augustsson. - - chalmers/original -- the original -- version 0.1. - - chalmers/thiemann -- Peter Thiemann added "indentation stuff" - and fontification -- version 0.2. - - chalmers/sof -- Sigbjorn Finne's <sof@dcs.gla.ac.uk> hacked - version of Thiemann's. - -....................................................................... - -* "Glasgow Haskell mode family" -- originally written by Richard McPhee - et al., at Glasgow University, as a student project, for Kevin - Hammond. - - glasgow/original : version 1.0, now maintained by - gem@minster.york.ac.uk - -....................................................................... - -* "Simon Marlow Haskell mode family" -- This is the one that comes - with GHC, versions 0.16 up to at least 0.26. - - simonm/real : the real thing - - simonm/ghc : the one distributed with GHC 0.16-0.26; no particular - reason to prefer this one... - -....................................................................... - -* "Yale Haskell mode family" -- Especially good for chatting to a - Yale-Haskell inferior process :-) - - yale/original : the real thing - - yale/chak : "extended by Manuel M.T. Chakravarty with rudimentary - editing features (including better syntax table) and support - for the font-lock-mode." Via Hans Wolfgang Loidl - <hwloidl@dcs.gla.ac.uk> diff --git a/ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el b/ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el deleted file mode 100644 index 167956d429..0000000000 --- a/ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el +++ /dev/null @@ -1,543 +0,0 @@ -;; haskell-mode.el. Major mode for editing Haskell. -;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen -;; and Lennart Augustsson - -;; This file is not officially part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0) -;; ================================================================= -;; -;; This is a mode for editing and running Haskell. -;; It is very much based on the sml mode for GNU Emacs. It -;; features: -;; -;; - Inferior shell running Haskell. No need to leave emacs, just -;; keep right on editing while Haskell runs in another window. -;; -;; - Automatic "load file" in inferior shell. Send regions of code -;; to the Haskell program. -;; -;; -;; 1. HOW TO USE THE Haskell-MODE -;; ========================== -;; -;; Here is a short introduction to the mode. -;; -;; 1.1 GETTING STARTED -;; ------------------- -;; -;; If you are an experienced user of Emacs, just skip this section. -;; -;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your -;; emacs-administrator to help you.): -;; -;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode) -;; auto-mode-alist))) -;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t) -;; -;; Now every time a file with the extension `.hs' or `.lhs' is found, it is -;; automatically started up in haskell-mode. -;; -;; You will also have to specify the path to this file, so you will have -;; to add this as well: -;; -;; (setq load-path (cons "/usr/me/emacs" load-path)) -;; -;; where "/usr/me/emacs" is the directory where this file is. -;; -;; You may also want to compile the this file (M-x byte-compile-file) -;; for speed. -;; -;; You are now ready to start using haskell-mode. If you have tried other -;; language modes (like lisp-mode or C-mode), you should have no -;; problems. There are only a few extra functions in this mode. -;; -;; 1.2. EDITING COMMANDS. -;; ---------------------- -;; -;; The following editing and inferior-shell commands can ONLY be issued -;; from within a buffer in haskell-mode. -;; -;; LFD (reindent-then-newline-and-indent). -;; This is probably the function you will be using the most (press -;; CTRL while you press Return, press C-j or press Newline). It -;; will reindent the line, then make a new line and perform a new -;; indentation. -;; -;; M-; (indent-for-comment). -;; Like in other language modes, this command will give you a comment -;; at the of the current line. The column where the comment starts is -;; determined by the variable comment-column (default: 40). -;; -;; C-c C-v (haskell-mode-version). -;; Get the version of the haskell-mode. -;; -;; -;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL -;; ------------------------------------------- -;; -;; C-c C-s (haskell-pop-to-shell). -;; This command starts up an inferior shell running haskell. If the shell -;; is running, it will just pop up the shell window. -;; -;; C-c C-u (haskell-save-buffer-use-file). -;; This command will save the current buffer and send a "load file", -;; where file is the file visited by the current buffer, to the -;; inferior shell running haskell. -;; -;; C-c C-f (haskell-run-on-file). -;; Will send a "load file" to the inferior shell running haskell, -;; prompting you for the file name. -;; -;; C-c C-r (haskell-send-region). -;; Will send region, from point to mark, to the inferior shell -;; running haskell. -;; -;; C-c C-b (haskell-send-buffer). -;; Will send whole buffer to inferior shell running haskell. -;; -;; 2. INDENTATION -;; ================ -;; Not yet. -;; -;; 3. INFERIOR SHELL. -;; ================== -;; -;; The mode for Standard ML also contains a mode for an inferior shell -;; running haskell. The mode is the same as the shell-mode, with just one -;; extra command. -;; -;; 3.1. INFERIOR SHELL COMMANDS -;; ---------------------------- -;; -;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running -;; haskell. -;; -;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE -;; -------------------------------------------------- -;; -;; Because haskell is called differently on various machines, and the -;; haskell-systems have their own command for reading in a file, a set of -;; constants controls the behavior of the inferior shell running haskell (to -;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below). -;; -;; haskell-prog-name (default "hbi"). -;; This constant is a string, containing the command to invoke -;; Standard ML on your system. -;; -;; haskell-use-right-delim (default "\"") -;; haskell-use-left-delim (default "\"") -;; The left and right delimiter used by your version of haskell, for -;; `use file-name'. -;; -;; haskell-process-name (default "Haskell"). -;; The name of the process running haskell. (This will be the name -;; appearing on the mode line of the buffer) -;; -;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and -;; haskell-send-region, creates temporary files (I could not figure out how -;; to send large amounts of data to a process). These files will be -;; removed when you leave emacs. -;; -;; -;; 4. CUSTOMIZING YOUR Haskell-MODE -;; ============================ -;; -;; If you have to change some of the constants, you will have to add a -;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file. -;; -;; (setq haskell-mode-hook 'my-haskell-constants) -;; -;; Your function "my-haskell-constants" will then be executed every time -;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp -;; function "my-haskell-constants", and put it in your "~/.emacs" file. -;; -;; Say you are running a version of haskell that uses the syntax `load -;; ["file"]', is invoked by the command "OurHaskell" and you don't want the -;; indentation algorithm to indent according to open parenthesis, your -;; function should look like this: -;; -;; (defun my-haskell-constants () -;; (setq haskell-prog-name "OurHaskell") -;; (setq haskell-use-left-delim "[\"") -;; (setq haskell-use-right-delim "\"]") -;; (setq haskell-paren-lookback nil)) -;; -;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; -;; ORIGINAL AUTHOR -;; Lars Bo Nielsen -;; Aalborg University -;; Computer Science Dept. -;; 9000 Aalborg -;; Denmark -;; -;; lbn@iesd.dk -;; or: ...!mcvax!diku!iesd!lbn -;; or: mcvax!diku!iesd!lbn@uunet.uu.net -;; -;; MODIFIED FOR Haskell BY -;; Lennart Augustsson -;; -;; -;; Please let me know if you come up with any ideas, bugs, or fixes. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst haskell-mode-version-string - "HASKELL-MODE, Version 0.1") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; CONSTANTS CONTROLLING THE MODE. -;;; -;;; These are the constants you might want to change -;;; - -;; The command used to start up the haskell-program. -(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.") - -;; The left delimmitter for `load file' -(defconst haskell-use-left-delim "\"" - "*The left delimiter for the filename when using \"load\".") - -;; The right delimmitter for `load file' -(defconst haskell-use-right-delim "\"" - "*The right delimiter for the filename when using \"load\".") - -;; A regular expression matching the prompt pattern in the inferior -;; shell -(defconst haskell-shell-prompt-pattern "^> *" - "*The prompt pattern for the inferion shell running haskell.") - -;; The template used for temporary files, created when a region is -;; send to the inferior process running haskell. -(defconst haskell-tmp-template "/tmp/haskell.tmp." - "*Template for the temporary file, created by haskell-simulate-send-region.") - -;; The name of the process running haskell (This will also be the name of -;; the buffer). -(defconst haskell-process-name "Haskell" "*The name of the Haskell-process") - -;;; -;;; END OF CONSTANTS CONTROLLING THE MODE. -;;; -;;; If you change anything below, you are on your own. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.") - -(defvar haskell-mode-map nil "The mode map used in haskell-mode.") - -(defun haskell-mode () - "Major mode for editing Haskell code. -Tab indents for Haskell code. -Comments are delimited with -- -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Key bindings: -============= - -\\[haskell-pop-to-shell]\t Pop to the haskell window. -\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\". -\\[haskell-send-region]\t Send region (point and mark) to haskell. -\\[haskell-run-on-file]\t Send a \"load file\" to haskell. -\\[haskell-send-buffer]\t Send whole buffer to haskell. -\\[haskell-mode-version]\t Get the version of haskell-mode. -\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it. - - -Mode map -======== -\\{haskell-mode-map} -Runs haskell-mode-hook if non nil." - (interactive) - (kill-all-local-variables) - (if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version) - (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file) - (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell) - (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region) - (define-key haskell-mode-map "\C-c\C-m" 'haskell-region) - (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file) - (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer) - (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression) - (define-key haskell-mode-map "\C-j" 'reindent-then-newline-and-indent) - (define-key haskell-mode-map "\177" 'backward-delete-char-untabify)) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ()) - (setq local-abbrev-table haskell-mode-abbrev-table) - (if haskell-mode-syntax-table - () - (setq haskell-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\( "()1" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(4" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) - (modify-syntax-entry ?* ". 23" haskell-mode-syntax-table) - ;; Special characters in haskell-mode to be treated as normal - ;; characters: - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - ) - (set-syntax-table haskell-mode-syntax-table) - (make-local-variable 'require-final-newline) ; Always put a new-line - (setq require-final-newline t) ; in the end of file - (make-local-variable 'indent-line-function) - (setq indent-line-function 'haskell-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "-- ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 39) ; Start of comment in this column - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+[ \t]?") ; This matches a start of comment - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'haskell-comment-indent) - ;; - ;; Adding these will fool the matching of parens. I really don't - ;; know why. It would be nice to have comments treated as - ;; white-space - ;; - ;; (make-local-variable 'parse-sexp-ignore-comments) - ;; (setq parse-sexp-ignore-comments t) - ;; - (run-hooks 'haskell-mode-hook)) ; Run the hook - -(defun haskell-mode-version () - (interactive) - (message haskell-mode-version-string)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INDENTATION -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun haskell-indent-line () - "Indent current line of Haskell code." - (interactive) - (let ((indent (haskell-calculate-indentation))) - (if (/= (current-indentation) indent) - (let ((beg (progn (beginning-of-line) (point)))) - (skip-chars-forward "\t ") - (delete-region beg (point)) - (indent-to indent)) - ;; If point is before indentation, move point to indentation - (if (< (current-column) (current-indentation)) - (skip-chars-forward "\t "))))) - -(defun haskell-calculate-indentation () - (save-excursion - (previous-line 1) - (beginning-of-line) ; Go to first non whitespace - (skip-chars-forward "\t ") ; on the line. - (current-column))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INFERIOR SHELL -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-shell-map nil "The mode map for haskell-shell.") - -(defun haskell-shell () - "Inferior shell invoking Haskell. -It is not possible to have more than one shell running Haskell. -Like the shell mode with the additional command: - -\\[haskell-run-on-file]\t Runs haskell on the file. -\\{haskell-shell-map} -Variables controlling the mode: - -haskell-prog-name (default \"hbi\") - The string used to invoke the haskell program. - -haskell-use-right-delim (default \"\\\"\") -haskell-use-left-delim (default \"\\\"\") - The left and right delimiter used by your version of haskell, for - \"load file-name\". - -haskell-process-name (default \"Haskell\") - The name of the process running haskell. - -haskell-shell-prompt-pattern (default \"^> *\") - The prompt pattern. - -Runs haskell-shell-hook if not nil." - (interactive) - (if (not (process-status haskell-process-name)) - (save-excursion ; Process is not running - (message "Starting Haskell...") ; start up a new process - (require 'shell) - (set-buffer (make-shell haskell-process-name haskell-prog-name)) - (erase-buffer) ; Erase the buffer if a previous - (if haskell-shell-map ; process died in there - () - (setq haskell-shell-map (copy-sequence shell-mode-map)) - (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file)) - (use-local-map haskell-shell-map) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern haskell-shell-prompt-pattern) - (setq major-mode 'haskell-shell) - (setq mode-name "Haskell Shell") - (setq mode-line-format - "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-") - (set-process-filter (get-process haskell-process-name) 'haskell-process-filter) - (message "Starting Haskell...done.") - (run-hooks 'haskell-shell-hook)))) - -(defun haskell-process-filter (proc str) - (let ((cur (current-buffer)) - (pop-up-windows t)) - (pop-to-buffer (concat "*" haskell-process-name "*")) - (goto-char (point-max)) - (if (string= str "\b\b\b \b\b\b") - (backward-delete-char 4) - (insert str)) - (set-marker (process-mark proc) (point-max)) - (pop-to-buffer cur))) - -(defun haskell-pop-to-shell () - (interactive) - (haskell-shell) - (pop-to-buffer (concat "*" haskell-process-name "*"))) - -(defun haskell-run-on-file (fil) - (interactive "FRun Haskell on : ") - (haskell-shell) - (save-some-buffers) - (send-string haskell-process-name - (concat "load " haskell-use-left-delim (expand-file-name fil) - haskell-use-right-delim ";\n"))) - -(defun haskell-save-buffer-use-file () - "Save the buffer, and send a `use file' to the inferior shell -running Haskell." - (interactive) - (let (file) - (if (setq file (buffer-file-name)) ; Is the buffer associated - (progn ; with file ? - (save-buffer) - (haskell-shell) - (send-string haskell-process-name - (concat "load " haskell-use-left-delim - (expand-file-name file) - haskell-use-right-delim ";\n"))) - (error "Buffer not associated with file.")))) - -(defvar haskell-tmp-files-list nil - "List of all temporary files created by haskell-simulate-send-region. -Each element in the list is a list with the format: - - (\"tmp-filename\" buffer start-line)") - -(defvar haskell-simulate-send-region-called-p nil - "Has haskell-simulate-send-region been called previously.") - -(defun haskell-make-temp-name (pre) - (concat (make-temp-name pre) ".m")) - -(defun haskell-simulate-send-region (point1 point2) - "Simulate send region. As send-region only can handle what ever the -system sets as the default, we have to make a temporary file. -Updates the list of temporary files (haskell-tmp-files-list)." - (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template)))) - ;; Remove temporary files when we leave emacs - (if (not haskell-simulate-send-region-called-p) - (progn - (setq haskell-old-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'haskell-remove-tmp-files) - (setq haskell-simulate-send-region-called-p t))) - (save-excursion - (goto-char point1) - (setq haskell-tmp-files-list - (cons (list file - (current-buffer) - (save-excursion ; Calculate line no. - (beginning-of-line) - (1+ (count-lines 1 (point))))) - haskell-tmp-files-list))) - (write-region point1 point2 file nil 'dummy) - (haskell-shell) - (message "Using temporary file: %s" file) - (send-string - haskell-process-name - ;; string to send: load file; - (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n")))) - -(defvar haskell-old-kill-emacs-hook nil - "Old value of kill-emacs-hook") - -(defun haskell-remove-tmp-files () - "Remove the temporary files, created by haskell-simulate-send-region, if -they still exist. Only files recorded in haskell-tmp-files-list are removed." - (message "Removing temporary files created by haskell-mode...") - (while haskell-tmp-files-list - (condition-case () - (delete-file (car (car haskell-tmp-files-list))) - (error ())) - (setq haskell-tmp-files-list (cdr haskell-tmp-files-list))) - (message "Removing temporary files created by haskell-mode...done.") - (run-hooks 'haskell-old-kill-emacs-hook)) - -(defun haskell-send-region () - "Send region." - (interactive) - (let (start end) - (save-excursion - (setq end (point)) - (exchange-point-and-mark) - (setq start (point))) - (haskell-simulate-send-region start end))) - -(defun haskell-send-buffer () - "Send the buffer." - (interactive) - (haskell-simulate-send-region (point-min) (point-max))) - -(defun haskell-evaluate-expression (h-expr) - "Prompt for and evaluate an expression" - (interactive "sExpression: ") - (let ((str (concat h-expr ";\n")) - (buf (current-buffer))) - (haskell-pop-to-shell) - (insert str) - (send-string haskell-process-name str) - (pop-to-buffer buf))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; END OF Haskell-MODE -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el b/ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el deleted file mode 100644 index 25a4324ad8..0000000000 --- a/ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el +++ /dev/null @@ -1,825 +0,0 @@ -;; haskell-mode.el. Major mode for editing Haskell. -;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen -;; and Lennart Augustsson -;; modified by Peter Thiemann, March 1994 - -;; This file is not officially part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0) -;; ================================================================= -;; -;; This is a mode for editing and running Haskell. -;; It is very much based on the sml mode for GNU Emacs. It -;; features: -;; -;; - Inferior shell running Haskell. No need to leave emacs, just -;; keep right on editing while Haskell runs in another window. -;; -;; - Automatic "load file" in inferior shell. Send regions of code -;; to the Haskell program. -;; -;; -;; 1. HOW TO USE THE Haskell-MODE -;; ========================== -;; -;; Here is a short introduction to the mode. -;; -;; 1.1 GETTING STARTED -;; ------------------- -;; -;; If you are an experienced user of Emacs, just skip this section. -;; -;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your -;; emacs-administrator to help you.): -;; -;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode) -;; auto-mode-alist))) -;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t) -;; -;; Now every time a file with the extension `.hs' or `.lhs' is found, it is -;; automatically started up in haskell-mode. -;; -;; You will also have to specify the path to this file, so you will have -;; to add this as well: -;; -;; (setq load-path (cons "/usr/me/emacs" load-path)) -;; -;; where "/usr/me/emacs" is the directory where this file is. -;; -;; You may also want to compile the this file (M-x byte-compile-file) -;; for speed. -;; -;; You are now ready to start using haskell-mode. If you have tried other -;; language modes (like lisp-mode or C-mode), you should have no -;; problems. There are only a few extra functions in this mode. -;; -;; 1.2. EDITING COMMANDS. -;; ---------------------- -;; -;; The following editing and inferior-shell commands can ONLY be issued -;; from within a buffer in haskell-mode. -;; -;; LFD (haskell-newline-and-indent). -;; This is probably the function you will be using the most (press -;; CTRL while you press Return, press C-j or press Newline). It -;; makes a new line and performs indentation based on the last -;; preceding non-comment line. -;; -;; M-; (indent-for-comment). -;; Like in other language modes, this command will give you a comment -;; at the of the current line. The column where the comment starts is -;; determined by the variable comment-column (default: 40). -;; -;; C-c C-v (haskell-mode-version). -;; Get the version of the haskell-mode. -;; -;; -;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL -;; ------------------------------------------- -;; -;; C-c C-s (haskell-pop-to-shell). -;; This command starts up an inferior shell running haskell. If the shell -;; is running, it will just pop up the shell window. -;; -;; C-c C-u (haskell-save-buffer-use-file). -;; This command will save the current buffer and send a "load file", -;; where file is the file visited by the current buffer, to the -;; inferior shell running haskell. -;; -;; C-c C-f (haskell-run-on-file). -;; Will send a "load file" to the inferior shell running haskell, -;; prompting you for the file name. -;; -;; C-c C-r (haskell-send-region). -;; Will send region, from point to mark, to the inferior shell -;; running haskell. -;; -;; C-c C-b (haskell-send-buffer). -;; Will send whole buffer to inferior shell running haskell. -;; -;; 2. INDENTATION -;; ================ -;; -;; The first indentation command (using C-j or TAB) on a given line -;; indents like the last preceding non-comment line. The next TAB -;; indents to the indentation of the innermost enclosing scope. Further -;; TABs get you to further enclosing scopes. After indentation has -;; reached the first column, the process restarts using the indentation -;; of the preceding non-comment line, again. -;; -;; 3. INFERIOR SHELL. -;; ================== -;; -;; The mode for Standard ML also contains a mode for an inferior shell -;; running haskell. The mode is the same as the shell-mode, with just one -;; extra command. -;; -;; 3.1. INFERIOR SHELL COMMANDS -;; ---------------------------- -;; -;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running -;; haskell. -;; -;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE -;; -------------------------------------------------- -;; -;; Because haskell is called differently on various machines, and the -;; haskell-systems have their own command for reading in a file, a set of -;; constants controls the behavior of the inferior shell running haskell (to -;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below). -;; -;; haskell-prog-name (default "hbi"). -;; This constant is a string, containing the command to invoke -;; Standard ML on your system. -;; -;; haskell-use-right-delim (default "\"") -;; haskell-use-left-delim (default "\"") -;; The left and right delimiter used by your version of haskell, for -;; `use file-name'. -;; -;; haskell-process-name (default "Haskell"). -;; The name of the process running haskell. (This will be the name -;; appearing on the mode line of the buffer) -;; -;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and -;; haskell-send-region, creates temporary files (I could not figure out how -;; to send large amounts of data to a process). These files will be -;; removed when you leave emacs. -;; -;; 4. FONTIFICATION -;; -;; There is support for Jamie Zawinski's font-lock-mode through the -;; variable "haskell-font-lock-keywords". -;; -;; 5. CUSTOMIZING YOUR Haskell-MODE -;; ============================ -;; -;; If you have to change some of the constants, you will have to add a -;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file. -;; -;; (setq haskell-mode-hook 'my-haskell-constants) -;; -;; Your function "my-haskell-constants" will then be executed every time -;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp -;; function "my-haskell-constants", and put it in your "~/.emacs" file. -;; -;; Say you are running a version of haskell that uses the syntax `load -;; ["file"]', is invoked by the command "OurHaskell" and you don't want the -;; indentation algorithm to indent according to open parenthesis, your -;; function should look like this: -;; -;; (defun my-haskell-constants () -;; (setq haskell-prog-name "OurHaskell") -;; (setq haskell-use-left-delim "[\"") -;; (setq haskell-use-right-delim "\"]") -;; (setq haskell-paren-lookback nil)) -;; -;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; -;; ORIGINAL AUTHOR -;; Lars Bo Nielsen -;; Aalborg University -;; Computer Science Dept. -;; 9000 Aalborg -;; Denmark -;; -;; lbn@iesd.dk -;; or: ...!mcvax!diku!iesd!lbn -;; or: mcvax!diku!iesd!lbn@uunet.uu.net -;; -;; MODIFIED FOR Haskell BY -;; Lennart Augustsson -;; indentation stuff by Peter Thiemann -;; -;; -;; Please let me know if you come up with any ideas, bugs, or fixes. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst haskell-mode-version-string - "HASKELL-MODE, Version 0.2, PJT indentation") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; CONSTANTS CONTROLLING THE MODE. -;;; -;;; These are the constants you might want to change -;;; - -;; The command used to start up the haskell-program. -(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.") - -;; The left delimmitter for `load file' -(defconst haskell-use-left-delim "\"" - "*The left delimiter for the filename when using \"load\".") - -;; The right delimmitter for `load file' -(defconst haskell-use-right-delim "\"" - "*The right delimiter for the filename when using \"load\".") - -;; A regular expression matching the prompt pattern in the inferior -;; shell -(defconst haskell-shell-prompt-pattern "^> *" - "*The prompt pattern for the inferion shell running haskell.") - -;; The template used for temporary files, created when a region is -;; send to the inferior process running haskell. -(defconst haskell-tmp-template "/tmp/haskell.tmp." - "*Template for the temporary file, created by haskell-simulate-send-region.") - -;; The name of the process running haskell (This will also be the name of -;; the buffer). -(defconst haskell-process-name "Haskell" "*The name of the Haskell-process") - -;;; -;;; END OF CONSTANTS CONTROLLING THE MODE. -;;; -;;; If you change anything below, you are on your own. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.") - -(defvar haskell-mode-map nil "The mode map used in haskell-mode.") - -(defvar haskell-mode-abbrev-table nil "The abbrev-table used in haskell-mode.") - -(defvar haskell-old-kill-emacs-hook nil "Old value of kill-emacs-hook") - -(defun haskell-mode () - "Major mode for editing Haskell code. -Tab indents for Haskell code. -Comments are delimited with -- -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Key bindings: -============= - -\\[haskell-pop-to-shell]\t Pop to the haskell window. -\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\". -\\[haskell-send-region]\t Send region (point and mark) to haskell. -\\[haskell-run-on-file]\t Send a \"load file\" to haskell. -\\[haskell-send-buffer]\t Send whole buffer to haskell. -\\[haskell-mode-version]\t Get the version of haskell-mode. -\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it. - - -Mode map -======== -\\{haskell-mode-map} -Runs haskell-mode-hook if non nil." - (interactive) - (kill-all-local-variables) - (if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version) - (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file) - (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell) - (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region) - (define-key haskell-mode-map "\C-c\C-m" 'haskell-region) - (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file) - (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer) - (define-key haskell-mode-map "\C-c\C-l" 'comment-line) - (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression) -; (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent) - (define-key haskell-mode-map [S-tab] 'tab-to-tab-stop) - (define-key haskell-mode-map "\177" 'backward-delete-char-untabify)) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ()) - (setq local-abbrev-table haskell-mode-abbrev-table) - (if haskell-mode-syntax-table - () - (setq haskell-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) -; partain: out -; (modify-syntax-entry ?- "_ 2356" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end out -; partain: in - (modify-syntax-entry ?- "_ 23" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end in - (modify-syntax-entry ?\\ "\\" haskell-mode-syntax-table) - (modify-syntax-entry ?* "_" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?' "_" haskell-mode-syntax-table) - (modify-syntax-entry ?: "_" haskell-mode-syntax-table) - (modify-syntax-entry ?| "." haskell-mode-syntax-table) - ) - (set-syntax-table haskell-mode-syntax-table) - (make-local-variable 'require-final-newline) ; Always put a new-line - (setq require-final-newline t) ; in the end of file -; (make-local-variable 'change-major-mode-hook) -; (setq change-major-mode-hook nil) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'haskell-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "-- ") -; (setq comment-start "{- ") - (make-local-variable 'comment-end) - (setq comment-end "") -; (setq comment-end " -}") - (make-local-variable 'comment-column) - (setq comment-column 60) ; Start of comment in this column - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "{-+ *\\|--+ *") ; This matches a start of comment - (make-local-variable 'comment-multi-line) - (setq comment-multi-line nil) -; (make-local-variable 'comment-indent-function) -; (setq comment-indent-function 'haskell-comment-indent) - ;; - ;; Adding these will fool the matching of parens. I really don't - ;; know why. It would be nice to have comments treated as - ;; white-space - ;; - ;; (make-local-variable 'parse-sexp-ignore-comments) - ;; (setq parse-sexp-ignore-comments t) - ;; - (run-hooks 'haskell-mode-hook)) ; Run the hook - -(defun haskell-mode-version () - (interactive) - (message haskell-mode-version-string)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INDENTATION -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; some variables for later use - -(defvar haskell-open-comment "{-") -(defvar haskell-close-comment "-}") -(defvar haskell-indentation-counter 0 - "count repeated invocations of indent-for-tab-command") -(defvar haskell-literate-flag nil - "used to guide literate/illiterate behavior, set automagically") - -(defun haskell-newline-and-indent () - (interactive) - (setq haskell-literate-flag - (save-excursion - (beginning-of-line) - (= (following-char) ?>))) - (newline) - (if haskell-literate-flag (insert ">")) - (haskell-indent-line)) - -(defun haskell-indent-line () - "Indent current line of ordinary or literate Haskell code." - (interactive) - (let ((indent (haskell-calculate-indentation-pjt-2))) - (if (/= (current-indentation) indent) - (let ((beg (progn - (beginning-of-line) - (if (= (following-char) ?>) (forward-char 1)) ;LITERATE - (point)))) - (skip-chars-forward "\t ") - (delete-region beg (point)) - (indent-to indent)) - ;; If point is before indentation, move point to indentation - (if (< (current-column) (current-indentation)) - (skip-chars-forward "\t "))))) - -(defun haskell-calculate-indentation () - (save-excursion - (let ((col (current-column))) - (while (and (not (bobp)) ;skip over empty and comment-only lines - (= col (current-column))) - (previous-line 1) - (beginning-of-line) ; Go to first non whitespace - (if (= (following-char) ?>) ;LITERATE - (forward-char 1) - (if haskell-literate-flag ;ignore illiterate lines - (end-of-line))) - (skip-chars-forward "\t ") ; on the line. - (setq col (current-column)) - (search-forward-regexp (concat haskell-open-comment "\\|--\\|\n") nil 0) - (goto-char (match-beginning 0))) - (search-backward-regexp "\\b\\(where\\|let\\|of\\|in\\)\\b\\|\n" nil 0) - (if (looking-at "\n") - () - (setq col (current-column)) - (forward-word 1) - (skip-chars-forward "\t ") - (if (looking-at "\\w") - (setq col (current-column)) - (setq col (+ 2 col)))) - col))) - -(defun haskell-calculate-indentation-pjt-2 () - "Calculate indentation for Haskell program code, versatile version" - (save-excursion - (if (eq last-command 'haskell-indentation) - (setq haskell-indentation-counter (1+ haskell-indentation-counter)) - (setq haskell-indentation-counter -1)) - (setq this-command 'haskell-indentation) - (let* ((simple-indent (haskell-calculate-indentation)) - (count haskell-indentation-counter) - (min-indent simple-indent) ; minimum indentation found in a non-comment line - (last-indent simple-indent) ; indentation of the following non-comment line - (return-indent nil) ; computed indentation - (comment-depth 0)) - (previous-line 1) - (if (< haskell-indentation-counter 0) ; 1st tab gives simple indentation - (setq return-indent simple-indent)) - (while (not return-indent) - (if (search-backward-regexp "\\b\\(where\\|let\\|of\\)\\b\\|\n\\|{-\\|-}" nil t 1) - (cond - ((looking-at haskell-open-comment) - (setq comment-depth (1- comment-depth))) - ((looking-at haskell-close-comment) - (setq comment-depth (1+ comment-depth))) - ((= 0 comment-depth) - (cond - ((looking-at "\n") - (save-excursion - (forward-char 1) - (if (= (following-char) ?>) - (forward-char 1) - (if haskell-literate-flag - (end-of-line))) ;LITERATE: ignore lines w/o > - (skip-chars-forward "\t ") - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column)) - (if (< last-indent min-indent) - (setq min-indent last-indent))))) - (t ; looking at a keyword - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (if (and haskell-literate-flag ;LITERATE: ignore lines w/o > - (save-excursion - (beginning-of-line) - (/= (following-char) ?>))) - (end-of-line)) - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column))) - (if (<= last-indent min-indent) - (if (> count 0) - (setq count (1- count)) - (setq return-indent last-indent))) - (if (< last-indent min-indent) - (setq min-indent last-indent))))))) - (setq return-indent simple-indent) - (setq haskell-indentation-counter -1))) - return-indent))) - -(defun haskell-skip-nested-comment () - ;; point looks at opening {-, move over closing -} - ;; todo: specify what happens on failure, bounds check ... - (forward-char 2) - (let ((comment-depth 1)) - (while (> comment-depth 0) - (search-forward-regexp "{-\\|-}") - (goto-char (match-beginning 0)) - (setq comment-depth - (if (= (following-char) 123) ; code for opening brace - (1+ comment-depth) - (1- comment-depth))) - (goto-char (match-end 0))))) - - -;;;seemingly obsolete functions -(defun haskell-inside-of-inline-comment () - (let ((bolp (save-excursion - (beginning-of-line) - (point)))) - (search-backward comment-start bolp t 1))) - -(defun haskell-inside-of-nested-comment () - (save-excursion - (let ((count 0)) - (while - (search-backward-regexp "\\({-\\|-}\\)" 0 t 1) - (if (haskell-inside-of-inline-comment) - () - (if (looking-at haskell-open-comment) - (setq count (1+ count)) - (setq count (1- count))))) - (> count 0)))) - -(defun haskell-inside-of-comment () - (or (haskell-inside-of-inline-comment) - (haskell-inside-of-nested-comment))) - -;;;stolen from sml-mode.el -(defun haskell-comment-indent () - "Compute indentation for Haskell comments" - (if (looking-at "^--") - 0 - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) - comment-column)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INFERIOR SHELL -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-shell-map nil "The mode map for haskell-shell.") - -(defun haskell-shell () - "Inferior shell invoking Haskell. -It is not possible to have more than one shell running Haskell. -Like the shell mode with the additional command: - -\\[haskell-run-on-file]\t Runs haskell on the file. -\\{haskell-shell-map} -Variables controlling the mode: - -haskell-prog-name (default \"hbi\") - The string used to invoke the haskell program. - -haskell-use-right-delim (default \"\\\"\") -haskell-use-left-delim (default \"\\\"\") - The left and right delimiter used by your version of haskell, for - \"load file-name\". - -haskell-process-name (default \"Haskell\") - The name of the process running haskell. - -haskell-shell-prompt-pattern (default \"^> *\") - The prompt pattern. - -Runs haskell-shell-hook if not nil." - (interactive) - (if (not (process-status haskell-process-name)) - (save-excursion ; Process is not running - (message "Starting Haskell...") ; start up a new process - (require 'shell) - (set-buffer (make-comint haskell-process-name haskell-prog-name)) - (erase-buffer) ; Erase the buffer if a previous - (if haskell-shell-map ; process died in there - () - (setq haskell-shell-map (copy-keymap shell-mode-map)) - (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file)) - (use-local-map haskell-shell-map) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern haskell-shell-prompt-pattern) - (setq major-mode 'haskell-shell) - (setq mode-name "Haskell Shell") - (setq mode-line-format - "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-") - (set-process-filter (get-process haskell-process-name) 'haskell-process-filter) - (message "Starting Haskell...done.") - (run-hooks 'haskell-shell-hook)))) - -(defun haskell-process-filter (proc str) - (let ((cur (current-buffer)) - (pop-up-windows t)) - (pop-to-buffer (concat "*" haskell-process-name "*")) - (goto-char (point-max)) - (if (string= str "\b\b\b \b\b\b") - (backward-delete-char 4) - (insert str)) - (set-marker (process-mark proc) (point-max)) - (pop-to-buffer cur))) - -(defun haskell-pop-to-shell () - (interactive) - (haskell-shell) - (pop-to-buffer (concat "*" haskell-process-name "*"))) - -(defun haskell-run-on-file (fil) - (interactive "FRun Haskell on : ") - (haskell-shell) - (save-some-buffers) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim (expand-file-name fil) - haskell-use-right-delim ";\n"))) - -(defun haskell-save-buffer-use-file () - "Save the buffer, and send a `use file' to the inferior shell -running Haskell." - (interactive) - (let (file) - (if (setq file (buffer-file-name)) ; Is the buffer associated - (progn ; with file ? - (save-buffer) - (haskell-shell) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim - (expand-file-name file) - haskell-use-right-delim ";\n"))) - (error "Buffer not associated with file.")))) - -(defvar haskell-tmp-files-list nil - "List of all temporary files created by haskell-simulate-send-region. -Each element in the list is a list with the format: - - (\"tmp-filename\" buffer start-line)") - -(defvar haskell-simulate-send-region-called-p nil - "Has haskell-simulate-send-region been called previously.") - -(defun haskell-make-temp-name (pre) - (concat (make-temp-name pre) ".m")) - -(defun haskell-simulate-send-region (point1 point2) - "Simulate send region. As send-region only can handle what ever the -system sets as the default, we have to make a temporary file. -Updates the list of temporary files (haskell-tmp-files-list)." - (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template)))) - ;; Remove temporary files when we leave emacs - (if (not haskell-simulate-send-region-called-p) - (progn - (setq haskell-old-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'haskell-remove-tmp-files) - (setq haskell-simulate-send-region-called-p t))) - (save-excursion - (goto-char point1) - (setq haskell-tmp-files-list - (cons (list file - (current-buffer) - (save-excursion ; Calculate line no. - (beginning-of-line) - (1+ (count-lines 1 (point))))) - haskell-tmp-files-list))) - (write-region point1 point2 file nil 'dummy) - (haskell-shell) - (message "Using temporary file: %s" file) - (process-send-string - haskell-process-name - ;; string to send: load file; - (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n")))) - -(defun haskell-remove-tmp-files () - "Remove the temporary files, created by haskell-simulate-send-region, if -they still exist. Only files recorded in haskell-tmp-files-list are removed." - (message "Removing temporary files created by haskell-mode...") - (while haskell-tmp-files-list - (condition-case () - (delete-file (car (car haskell-tmp-files-list))) - (error ())) - (setq haskell-tmp-files-list (cdr haskell-tmp-files-list))) - (message "Removing temporary files created by haskell-mode...done.") - (run-hooks 'haskell-old-kill-emacs-hook)) - -(defun haskell-send-region () - "Send region." - (interactive) - (let (start end) - (save-excursion - (setq end (point)) - (exchange-point-and-mark) - (setq start (point))) - (haskell-simulate-send-region start end))) - -(defun haskell-send-buffer () - "Send the buffer." - (interactive) - (haskell-simulate-send-region (point-min) (point-max))) - -(defun haskell-evaluate-expression (h-expr) - "Prompt for and evaluate an expression" - (interactive "sExpression: ") - (let ((str (concat h-expr ";\n")) - (buf (current-buffer))) - (haskell-pop-to-shell) - (insert str) - (process-send-string haskell-process-name str) - (pop-to-buffer buf))) - - -;; -;; font-lock-mode patterns, based on specs. in an earlier version -;; of haskell-mode.el -;; (these patterns have only been tested with 19.30) - -(defconst haskell-font-lock-keywords nil - "Conservative highlighting of a Haskell buffer -(using font-lock.)") - -(let ((haskell-id "[a-z_][a-zA-Z0-9_'#]+") - (haskell-reserved-ids - (concat "\\b\\(" - (mapconcat - 'identity - '("case" "class" "data" - "default" "deriving" "else" - "hiding" "if" "import" "in" - "instance" "interface" "let" - "module" "of" "renaming" - "then" "to" "type" "where" "infix[rl]?") - "\\|") - "\\)[ \t\n:,]")) - (haskell-basic-types - (concat "\\b\\(" - (mapconcat 'identity - '("Bool" "()" "String" "Char" "Int" - "Integer" "Float" "Double" "Ratio" - "Assoc" "Rational" "Array") - "\\|") - "\\)\\b")) - (haskell-prelude-classes - (concat "\\b\\(" - (mapconcat 'identity - '("Eq" "Ord" "Text" "Num" "Real" "Fractional" - "Integral" "RealFrac" "Floating" "RealFloat" - "Complex" "Ix" "Enum" - ;; ghc-isms - "_CCallable" "_CReturnable") - "\\|") - "\\)\\b")) - (haskell-reserved-ops - (mapconcat 'identity - '("\\.\\." "::" - "=>" "/=" "@" - "<-" "->") - "\\|")) - (glasgow-haskell-ops - (concat "\\b\\(" - (mapconcat - 'identity - '(">>" ">>=" "thenPrimIO" - "seqPrimIO" "returnPrimIO" - "return" "_ccall_" "_casm_" - "thenST" "seqST" "returnST" - "thenStrictlyST" "seqStrictlyST" "returnStrictlyST" - "unsafeInterleavePrimIO" "unsafePerformIO") - "\\|") - "\\)\\b")) - (glasgow-haskell-types - (concat "\\b\\(" - (mapconcat - 'identity - '("IO" "PrimIO" "_?ST" - "_Word" "_Addr" "_?MVar" - "_?IVar" "_RealWorld" - "_?MutableByteArray" - "_?ByteArray") - "\\|") - "\\)\\b"))) - (setq haskell-font-lock-keywords - (list - '("--.*$" . font-lock-comment-face) - (list "[ \t\n]*\\([A-Za-z[(_][]A-Za-z0-9_$', ~@|:[)(#]*[ \t\n]*\\)=" 1 font-lock-function-name-face) - (list (concat "^>?[ \t\n]*\\(" haskell-id "\\)[ \t]*::") 1 'font-lock-function-name-face) - (list haskell-reserved-ids 0 'font-lock-function-name-face) - (list glasgow-haskell-ops 0 'font-lock-function-name-face) - (list glasgow-haskell-types 0 'font-lock-type-face) - (list haskell-basic-types 0 'font-lock-type-face) - (list haskell-prelude-classes 0 'font-lock-type-face) - (list "^[ \t\n]*\\([A-Za-z[(_][]A-Za-z0-9_$', @:[)(#]*[ \t\n]*\\)->" 1 font-lock-variable-name-face) - ))) - -;; -;; To enable font-lock-mode for Haskell buffers, add something -;; like this to your ~/.emacs - -;(cond (window-system -; (require 'font-lock) -; (add-hook 'haskell-mode-hook -; '(lambda () (make-local-variable 'font-lock-defaults) -; (make-local-variable 'font-lock-mode-hook) ; don't affect other buffers -; (setq font-lock-mode-hook nil) -; (add-hook 'font-lock-mode-hook -; '(lambda () -; (setq font-lock-keywords haskell-font-lock-keywords))) -; (font-lock-mode 1)))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; END OF Haskell-MODE -;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(provide 'haskell-mode) diff --git a/ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el b/ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el deleted file mode 100644 index e900f01a76..0000000000 --- a/ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el +++ /dev/null @@ -1,764 +0,0 @@ -;; haskell-mode.el. Major mode for editing Haskell. -;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen -;; and Lennart Augustsson -;; modified by Peter Thiemann, March 1994 - -;; This file is not officially part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0) -;; ================================================================= -;; -;; This is a mode for editing and running Haskell. -;; It is very much based on the sml mode for GNU Emacs. It -;; features: -;; -;; - Inferior shell running Haskell. No need to leave emacs, just -;; keep right on editing while Haskell runs in another window. -;; -;; - Automatic "load file" in inferior shell. Send regions of code -;; to the Haskell program. -;; -;; -;; 1. HOW TO USE THE Haskell-MODE -;; ========================== -;; -;; Here is a short introduction to the mode. -;; -;; 1.1 GETTING STARTED -;; ------------------- -;; -;; If you are an experienced user of Emacs, just skip this section. -;; -;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your -;; emacs-administrator to help you.): -;; -;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode) -;; auto-mode-alist))) -;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t) -;; -;; Now every time a file with the extension `.hs' or `.lhs' is found, it is -;; automatically started up in haskell-mode. -;; -;; You will also have to specify the path to this file, so you will have -;; to add this as well: -;; -;; (setq load-path (cons "/usr/me/emacs" load-path)) -;; -;; where "/usr/me/emacs" is the directory where this file is. -;; -;; You may also want to compile the this file (M-x byte-compile-file) -;; for speed. -;; -;; You are now ready to start using haskell-mode. If you have tried other -;; language modes (like lisp-mode or C-mode), you should have no -;; problems. There are only a few extra functions in this mode. -;; -;; 1.2. EDITING COMMANDS. -;; ---------------------- -;; -;; The following editing and inferior-shell commands can ONLY be issued -;; from within a buffer in haskell-mode. -;; -;; LFD (haskell-newline-and-indent). -;; This is probably the function you will be using the most (press -;; CTRL while you press Return, press C-j or press Newline). It -;; makes a new line and performs indentation based on the last -;; preceding non-comment line. -;; -;; M-; (indent-for-comment). -;; Like in other language modes, this command will give you a comment -;; at the of the current line. The column where the comment starts is -;; determined by the variable comment-column (default: 40). -;; -;; C-c C-v (haskell-mode-version). -;; Get the version of the haskell-mode. -;; -;; -;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL -;; ------------------------------------------- -;; -;; C-c C-s (haskell-pop-to-shell). -;; This command starts up an inferior shell running haskell. If the shell -;; is running, it will just pop up the shell window. -;; -;; C-c C-u (haskell-save-buffer-use-file). -;; This command will save the current buffer and send a "load file", -;; where file is the file visited by the current buffer, to the -;; inferior shell running haskell. -;; -;; C-c C-f (haskell-run-on-file). -;; Will send a "load file" to the inferior shell running haskell, -;; prompting you for the file name. -;; -;; C-c C-r (haskell-send-region). -;; Will send region, from point to mark, to the inferior shell -;; running haskell. -;; -;; C-c C-b (haskell-send-buffer). -;; Will send whole buffer to inferior shell running haskell. -;; -;; 2. INDENTATION -;; ================ -;; -;; The first indentation command (using C-j or TAB) on a given line -;; indents like the last preceding non-comment line. The next TAB -;; indents to the indentation of the innermost enclosing scope. Further -;; TABs get you to further enclosing scopes. After indentation has -;; reached the first column, the process restarts using the indentation -;; of the preceding non-comment line, again. -;; -;; 3. INFERIOR SHELL. -;; ================== -;; -;; The mode for Standard ML also contains a mode for an inferior shell -;; running haskell. The mode is the same as the shell-mode, with just one -;; extra command. -;; -;; 3.1. INFERIOR SHELL COMMANDS -;; ---------------------------- -;; -;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running -;; haskell. -;; -;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE -;; -------------------------------------------------- -;; -;; Because haskell is called differently on various machines, and the -;; haskell-systems have their own command for reading in a file, a set of -;; constants controls the behavior of the inferior shell running haskell (to -;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below). -;; -;; haskell-prog-name (default "hbi"). -;; This constant is a string, containing the command to invoke -;; Standard ML on your system. -;; -;; haskell-use-right-delim (default "\"") -;; haskell-use-left-delim (default "\"") -;; The left and right delimiter used by your version of haskell, for -;; `use file-name'. -;; -;; haskell-process-name (default "Haskell"). -;; The name of the process running haskell. (This will be the name -;; appearing on the mode line of the buffer) -;; -;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and -;; haskell-send-region, creates temporary files (I could not figure out how -;; to send large amounts of data to a process). These files will be -;; removed when you leave emacs. -;; -;; 4. FONTIFICATION -;; -;; There is support for Jamie Zawinski's font-lock-mode through the -;; variable "haskell-font-lock-keywords". -;; -;; 5. CUSTOMIZING YOUR Haskell-MODE -;; ============================ -;; -;; If you have to change some of the constants, you will have to add a -;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file. -;; -;; (setq haskell-mode-hook 'my-haskell-constants) -;; -;; Your function "my-haskell-constants" will then be executed every time -;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp -;; function "my-haskell-constants", and put it in your "~/.emacs" file. -;; -;; Say you are running a version of haskell that uses the syntax `load -;; ["file"]', is invoked by the command "OurHaskell" and you don't want the -;; indentation algorithm to indent according to open parenthesis, your -;; function should look like this: -;; -;; (defun my-haskell-constants () -;; (setq haskell-prog-name "OurHaskell") -;; (setq haskell-use-left-delim "[\"") -;; (setq haskell-use-right-delim "\"]") -;; (setq haskell-paren-lookback nil)) -;; -;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; -;; ORIGINAL AUTHOR -;; Lars Bo Nielsen -;; Aalborg University -;; Computer Science Dept. -;; 9000 Aalborg -;; Denmark -;; -;; lbn@iesd.dk -;; or: ...!mcvax!diku!iesd!lbn -;; or: mcvax!diku!iesd!lbn@uunet.uu.net -;; -;; MODIFIED FOR Haskell BY -;; Lennart Augustsson -;; indentation stuff by Peter Thiemann -;; -;; -;; Please let me know if you come up with any ideas, bugs, or fixes. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst haskell-mode-version-string - "HASKELL-MODE, Version 0.2, PJT indentation") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; CONSTANTS CONTROLLING THE MODE. -;;; -;;; These are the constants you might want to change -;;; - -;; The command used to start up the haskell-program. -(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.") - -;; The left delimmitter for `load file' -(defconst haskell-use-left-delim "\"" - "*The left delimiter for the filename when using \"load\".") - -;; The right delimmitter for `load file' -(defconst haskell-use-right-delim "\"" - "*The right delimiter for the filename when using \"load\".") - -;; A regular expression matching the prompt pattern in the inferior -;; shell -(defconst haskell-shell-prompt-pattern "^> *" - "*The prompt pattern for the inferion shell running haskell.") - -;; The template used for temporary files, created when a region is -;; send to the inferior process running haskell. -(defconst haskell-tmp-template "/tmp/haskell.tmp." - "*Template for the temporary file, created by haskell-simulate-send-region.") - -;; The name of the process running haskell (This will also be the name of -;; the buffer). -(defconst haskell-process-name "Haskell" "*The name of the Haskell-process") - -;;; -;;; END OF CONSTANTS CONTROLLING THE MODE. -;;; -;;; If you change anything below, you are on your own. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.") - -(defvar haskell-mode-map nil "The mode map used in haskell-mode.") - -(defvar haskell-mode-abbrev-table nil "The abbrev-table used in haskell-mode.") - -(defvar haskell-old-kill-emacs-hook nil "Old value of kill-emacs-hook") - -(defun haskell-mode () - "Major mode for editing Haskell code. -Tab indents for Haskell code. -Comments are delimited with -- -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Key bindings: -============= - -\\[haskell-pop-to-shell]\t Pop to the haskell window. -\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\". -\\[haskell-send-region]\t Send region (point and mark) to haskell. -\\[haskell-run-on-file]\t Send a \"load file\" to haskell. -\\[haskell-send-buffer]\t Send whole buffer to haskell. -\\[haskell-mode-version]\t Get the version of haskell-mode. -\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it. - - -Mode map -======== -\\{haskell-mode-map} -Runs haskell-mode-hook if non nil." - (interactive) - (kill-all-local-variables) - (if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version) - (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file) - (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell) - (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region) - (define-key haskell-mode-map "\C-c\C-m" 'haskell-region) - (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file) - (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer) - (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression) - (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent) - (define-key haskell-mode-map "\177" 'backward-delete-char-untabify)) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ()) - (setq local-abbrev-table haskell-mode-abbrev-table) - (if haskell-mode-syntax-table - () - (setq haskell-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) -; partain: out -; (modify-syntax-entry ?- "_ 2356" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end out -; partain: in - (modify-syntax-entry ?- "_ 23" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end in - (modify-syntax-entry ?\\ "\\" haskell-mode-syntax-table) - (modify-syntax-entry ?* "_" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?' "_" haskell-mode-syntax-table) - (modify-syntax-entry ?: "_" haskell-mode-syntax-table) - (modify-syntax-entry ?| "." haskell-mode-syntax-table) - ) - (set-syntax-table haskell-mode-syntax-table) - (make-local-variable 'require-final-newline) ; Always put a new-line - (setq require-final-newline t) ; in the end of file - (make-local-variable 'indent-line-function) - (setq indent-line-function 'haskell-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "-- ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 60) ; Start of comment in this column - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--[^a-zA-Z0-9]*") ; This matches a start of comment - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'haskell-comment-indent) - ;; - ;; Adding these will fool the matching of parens. I really don't - ;; know why. It would be nice to have comments treated as - ;; white-space - ;; - ;; (make-local-variable 'parse-sexp-ignore-comments) - ;; (setq parse-sexp-ignore-comments t) - ;; - (run-hooks 'haskell-mode-hook)) ; Run the hook - -(defun haskell-mode-version () - (interactive) - (message haskell-mode-version-string)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INDENTATION -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; some variables for later use - -(defvar haskell-open-comment "{-") -(defvar haskell-close-comment "-}") -(defvar haskell-indentation-counter 0 - "count repeated invocations of indent-for-tab-command") -(defvar haskell-literate-flag nil - "used to guide literate/illiterate behavior, set automagically") - -(defun haskell-newline-and-indent () - (interactive) - (setq haskell-literate-flag - (save-excursion - (beginning-of-line) - (= (following-char) ?>))) - (newline) - (if haskell-literate-flag (insert ">")) - (haskell-indent-line)) - -(defun haskell-indent-line () - "Indent current line of ordinary or literate Haskell code." - (interactive) - (let ((indent (haskell-calculate-indentation-pjt-2))) - (if (/= (current-indentation) indent) - (let ((beg (progn - (beginning-of-line) - (if (= (following-char) ?>) (forward-char 1)) ;LITERATE - (point)))) - (skip-chars-forward "\t ") - (delete-region beg (point)) - (indent-to indent)) - ;; If point is before indentation, move point to indentation - (if (< (current-column) (current-indentation)) - (skip-chars-forward "\t "))))) - -(defun haskell-calculate-indentation () - (save-excursion - (let ((col (current-column))) - (while (and (not (bobp)) ;skip over empty and comment-only lines - (= col (current-column))) - (previous-line 1) - (beginning-of-line) ; Go to first non whitespace - (if (= (following-char) ?>) ;LITERATE - (forward-char 1) - (if haskell-literate-flag ;ignore illiterate lines - (end-of-line))) - (skip-chars-forward "\t ") ; on the line. - (setq col (current-column)) - (search-forward-regexp (concat haskell-open-comment "\\|--\\|\n") nil 0) - (goto-char (match-beginning 0))) - (search-backward-regexp "\\b\\(where\\|let\\|of\\|in\\)\\b\\|\n" nil 0) - (if (looking-at "\n") - () - (setq col (current-column)) - (forward-word 1) - (skip-chars-forward "\t ") - (if (looking-at "\\w") - (setq col (current-column)) - (setq col (+ 2 col)))) - col))) - -(defun haskell-calculate-indentation-pjt-2 () - "Calculate indentation for Haskell program code, versatile version" - (save-excursion - (if (eq last-command 'haskell-indentation) - (setq haskell-indentation-counter (1+ haskell-indentation-counter)) - (setq haskell-indentation-counter -1)) - (setq this-command 'haskell-indentation) - (let* ((simple-indent (haskell-calculate-indentation)) - (count haskell-indentation-counter) - (min-indent simple-indent) ; minimum indentation found in a non-comment line - (last-indent simple-indent) ; indentation of the following non-comment line - (return-indent nil) ; computed indentation - (comment-depth 0)) - (previous-line 1) - (if (< haskell-indentation-counter 0) ; 1st tab gives simple indentation - (setq return-indent simple-indent)) - (while (not return-indent) - (if (search-backward-regexp "\\b\\(where\\|let\\|of\\)\\b\\|\n\\|{-\\|-}" nil t 1) - (cond - ((looking-at haskell-open-comment) - (setq comment-depth (1- comment-depth))) - ((looking-at haskell-close-comment) - (setq comment-depth (1+ comment-depth))) - ((= 0 comment-depth) - (cond - ((looking-at "\n") - (save-excursion - (forward-char 1) - (if (= (following-char) ?>) - (forward-char 1) - (if haskell-literate-flag - (end-of-line))) ;LITERATE: ignore lines w/o > - (skip-chars-forward "\t ") - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column)) - (if (< last-indent min-indent) - (setq min-indent last-indent))))) - (t ; looking at a keyword - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (if (and haskell-literate-flag ;LITERATE: ignore lines w/o > - (save-excursion - (beginning-of-line) - (/= (following-char) ?>))) - (end-of-line)) - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column))) - (if (<= last-indent min-indent) - (if (> count 0) - (setq count (1- count)) - (setq return-indent last-indent))) - (if (< last-indent min-indent) - (setq min-indent last-indent))))))) - (setq return-indent simple-indent) - (setq haskell-indentation-counter -1))) - return-indent))) - -(defun haskell-skip-nested-comment () - ;; point looks at opening {-, move over closing -} - ;; todo: specify what happens on failure, bounds check ... - (forward-char 2) - (let ((comment-depth 1)) - (while (> comment-depth 0) - (search-forward-regexp "{-\\|-}") - (goto-char (match-beginning 0)) - (setq comment-depth - (if (= (following-char) 123) ; code for opening brace - (1+ comment-depth) - (1- comment-depth))) - (goto-char (match-end 0))))) - - -;;;seemingly obsolete functions -(defun haskell-inside-of-inline-comment () - (let ((bolp (save-excursion - (beginning-of-line) - (point)))) - (search-backward comment-start bolp t 1))) - -(defun haskell-inside-of-nested-comment () - (save-excursion - (let ((count 0)) - (while - (search-backward-regexp "\\({-\\|-}\\)" 0 t 1) - (if (haskell-inside-of-inline-comment) - () - (if (looking-at haskell-open-comment) - (setq count (1+ count)) - (setq count (1- count))))) - (> count 0)))) - -(defun haskell-inside-of-comment () - (or (haskell-inside-of-inline-comment) - (haskell-inside-of-nested-comment))) - -;;;stolen from sml-mode.el -(defun haskell-comment-indent () - "Compute indentation for Haskell comments" - (if (looking-at "^--") - 0 - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) - comment-column)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INFERIOR SHELL -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-shell-map nil "The mode map for haskell-shell.") - -(defun haskell-shell () - "Inferior shell invoking Haskell. -It is not possible to have more than one shell running Haskell. -Like the shell mode with the additional command: - -\\[haskell-run-on-file]\t Runs haskell on the file. -\\{haskell-shell-map} -Variables controlling the mode: - -haskell-prog-name (default \"hbi\") - The string used to invoke the haskell program. - -haskell-use-right-delim (default \"\\\"\") -haskell-use-left-delim (default \"\\\"\") - The left and right delimiter used by your version of haskell, for - \"load file-name\". - -haskell-process-name (default \"Haskell\") - The name of the process running haskell. - -haskell-shell-prompt-pattern (default \"^> *\") - The prompt pattern. - -Runs haskell-shell-hook if not nil." - (interactive) - (if (not (process-status haskell-process-name)) - (save-excursion ; Process is not running - (message "Starting Haskell...") ; start up a new process - (require 'shell) - (set-buffer (make-comint haskell-process-name haskell-prog-name)) - (erase-buffer) ; Erase the buffer if a previous - (if haskell-shell-map ; process died in there - () - (setq haskell-shell-map (copy-keymap shell-mode-map)) - (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file)) - (use-local-map haskell-shell-map) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern haskell-shell-prompt-pattern) - (setq major-mode 'haskell-shell) - (setq mode-name "Haskell Shell") - (setq mode-line-format - "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-") - (set-process-filter (get-process haskell-process-name) 'haskell-process-filter) - (message "Starting Haskell...done.") - (run-hooks 'haskell-shell-hook)))) - -(defun haskell-process-filter (proc str) - (let ((cur (current-buffer)) - (pop-up-windows t)) - (pop-to-buffer (concat "*" haskell-process-name "*")) - (goto-char (point-max)) - (if (string= str "\b\b\b \b\b\b") - (backward-delete-char 4) - (insert str)) - (set-marker (process-mark proc) (point-max)) - (pop-to-buffer cur))) - -(defun haskell-pop-to-shell () - (interactive) - (haskell-shell) - (pop-to-buffer (concat "*" haskell-process-name "*"))) - -(defun haskell-run-on-file (fil) - (interactive "FRun Haskell on : ") - (haskell-shell) - (save-some-buffers) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim (expand-file-name fil) - haskell-use-right-delim ";\n"))) - -(defun haskell-save-buffer-use-file () - "Save the buffer, and send a `use file' to the inferior shell -running Haskell." - (interactive) - (let (file) - (if (setq file (buffer-file-name)) ; Is the buffer associated - (progn ; with file ? - (save-buffer) - (haskell-shell) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim - (expand-file-name file) - haskell-use-right-delim ";\n"))) - (error "Buffer not associated with file.")))) - -(defvar haskell-tmp-files-list nil - "List of all temporary files created by haskell-simulate-send-region. -Each element in the list is a list with the format: - - (\"tmp-filename\" buffer start-line)") - -(defvar haskell-simulate-send-region-called-p nil - "Has haskell-simulate-send-region been called previously.") - -(defun haskell-make-temp-name (pre) - (concat (make-temp-name pre) ".m")) - -(defun haskell-simulate-send-region (point1 point2) - "Simulate send region. As send-region only can handle what ever the -system sets as the default, we have to make a temporary file. -Updates the list of temporary files (haskell-tmp-files-list)." - (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template)))) - ;; Remove temporary files when we leave emacs - (if (not haskell-simulate-send-region-called-p) - (progn - (setq haskell-old-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'haskell-remove-tmp-files) - (setq haskell-simulate-send-region-called-p t))) - (save-excursion - (goto-char point1) - (setq haskell-tmp-files-list - (cons (list file - (current-buffer) - (save-excursion ; Calculate line no. - (beginning-of-line) - (1+ (count-lines 1 (point))))) - haskell-tmp-files-list))) - (write-region point1 point2 file nil 'dummy) - (haskell-shell) - (message "Using temporary file: %s" file) - (process-send-string - haskell-process-name - ;; string to send: load file; - (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n")))) - -(defun haskell-remove-tmp-files () - "Remove the temporary files, created by haskell-simulate-send-region, if -they still exist. Only files recorded in haskell-tmp-files-list are removed." - (message "Removing temporary files created by haskell-mode...") - (while haskell-tmp-files-list - (condition-case () - (delete-file (car (car haskell-tmp-files-list))) - (error ())) - (setq haskell-tmp-files-list (cdr haskell-tmp-files-list))) - (message "Removing temporary files created by haskell-mode...done.") - (run-hooks 'haskell-old-kill-emacs-hook)) - -(defun haskell-send-region () - "Send region." - (interactive) - (let (start end) - (save-excursion - (setq end (point)) - (exchange-point-and-mark) - (setq start (point))) - (haskell-simulate-send-region start end))) - -(defun haskell-send-buffer () - "Send the buffer." - (interactive) - (haskell-simulate-send-region (point-min) (point-max))) - -(defun haskell-evaluate-expression (h-expr) - "Prompt for and evaluate an expression" - (interactive "sExpression: ") - (let ((str (concat h-expr ";\n")) - (buf (current-buffer))) - (haskell-pop-to-shell) - (insert str) - (process-send-string haskell-process-name str) - (pop-to-buffer buf))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; keywords for jwz's font-look-mode (lemacs 19) -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(setq haskell-font-lock-keywords - (list (concat "\\b\\(" - (mapconcat 'identity - '("case" "class" "data" "default" "deriving" "else" "hiding" - "if" "import" "in" "infix" "infixl" "infixr" "instance" - "interface" "let" "module" "of" "renaming" "then" "to" - "type" "where") - "\\|") - "\\)\\b") - (list "^\\(#[ \t]*\\(if\\|ifdef\\|ifndef\\|else\\|endif\\|include\\)\\)") - (list "\\(^>?\\|\\bwhere\\b\\|\\blet\\b\\)[ \t]*\\(\\(\\w\\|\\s_\\)+\\)\\(\\([^=\n]*\\S.\\)?=\\(\\S.\\|$\\)\\|[ \t]*::\\S.\\).*$" - 2 'font-lock-function-name-face) - (list "\\b\\(data\\|type\\)\\b[ \t]+\\(\\(\\w\\|\\s_\\)+\\)" - 2 'font-lock-type-face) - (list (concat "'\\([^\\]\\|\\\\\\([0-9]+\\|" - (mapconcat 'identity - '("a" "b" "f" "n" "r" "t" "v" "\\\\" "\"" "'" "&") - "\\|") - "\\|\\^\\([][_^A-Z@\\\\]\\)" - "\\)\\)'") 1 'font-lock-string-face))) - -;;; font-lock-keywords for literate style files - -(setq haskell-font-lock-keywords-2 - (list (concat "^>.*\\b\\(" - (mapconcat 'identity - '("case" "class" "data" "default" "deriving" "else" "hiding" - "if" "import" "in" "infix" "infixl" "infixr" "instance" - "interface" "let" "module" "of" "renaming" "then" "to" - "type" "where") - "\\|") - "\\)\\b") - (list "^>\\(.*\\(\\bwhere\\b\\|\\blet\\b\\)\\|\\)[ \t]*\\(\\(\\w\\|\\s_\\)+\\)\\(\\([^=\n]*\\S.\\)?=\\(\\S.\\|$\\)\\|[ \t]*::\\S.\\).*$" - 3 'font-lock-function-name-face) - (list "^>.*\\b\\(data\\|type\\)\\b[ \t]+\\(\\(\\w\\|\\s_\\)+\\)" - 2 'font-lock-type-face) - (list (concat "^>.*'\\([^\\]\\|\\\\\\([0-9]+\\|" - (mapconcat 'identity - '("a" "b" "f" "n" "r" "t" "v" "\\\\" "\"" "'" "&") - "\\|") - "\\|\\^\\([][_^A-Z@\\\\]\\)" - "\\)\\)'") 1 'font-lock-string-face))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; END OF Haskell-MODE -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(provide 'haskell-mode) diff --git a/ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el b/ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el deleted file mode 100644 index b9a490ffd1..0000000000 --- a/ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el +++ /dev/null @@ -1,1935 +0,0 @@ -;; Haskell major mode -;; (c) Copyright, Richard McPhee et al. -;; University of Glasgow, February 1993 - - - -;; if .hs is not recognised then put the extension in auto-mode-list - -(if (assoc "\\.hs" auto-mode-alist) - nil - (nconc auto-mode-alist '(("\\.hs". haskell-mode)))) - -(if (assoc "\\.hi" auto-mode-alist) - nil - (nconc auto-mode-alist '(("\\.hi". haskell-mode)))) - -(if (assoc "\\.gs" auto-mode-alist) - nil - (nconc auto-mode-alist '(("\\.gs". haskell-mode)))) - -(defvar haskell-mode-syntax-table nil - "Syntax table for haskell-mode buffers.") - -(defvar haskell-mode-abbrev-table nil - "Abbrev table for haskell-mode buffers.") - -(defvar haskell-mode-map (make-sparse-keymap) - "Keymap for haskell-mode-buffers.") - - - -;;; Here are the keymaps used in haskell-mode - -(define-key haskell-mode-map "\M-;" 'haskell-insert-comment) -(define-key haskell-mode-map "\C-c=" 'haskell-insert-concat) -(define-key haskell-mode-map "\C-c;" 'set-haskell-comment-column) -(define-key haskell-mode-map "\C-c+" 'set-haskell-concat-column) -(define-key haskell-mode-map "\C-cn" 'set-haskell-indent-offset) -(define-key haskell-mode-map "\C-cl" 'set-haskell-list-offset) -(define-key haskell-mode-map "\C-ci" 'set-haskell-if-offset) -(define-key haskell-mode-map "\C-ce" 'set-haskell-let-offset) -(define-key haskell-mode-map "\C-cc" 'set-haskell-case-offset) -(define-key haskell-mode-map "\C-ct" 'set-haskell-then-offset) -(define-key haskell-mode-map "\C-co" 'set-haskell-comp-offset) -(define-key haskell-mode-map "\C-cw" 'set-haskell-where-offset) -(define-key haskell-mode-map "\C-cg" 'goto-line) -(define-key haskell-mode-map "\C-j" 'haskell-reindent-then-newline-and-indent) -(define-key haskell-mode-map "\t" 'haskell-indent-line) -(define-key haskell-mode-map "}" 'electric-haskell-brace) -(define-key haskell-mode-map "]" 'electric-haskell-brace) -(define-key haskell-mode-map ")" 'haskell-insert-round-paren) -(define-key haskell-mode-map "\C-cr" 'haskell-indent-region) -(define-key haskell-mode-map "\C-cf" 'haskell-further-indent) -(define-key haskell-mode-map "\C-cb" 'haskell-lesser-indent) -(define-key haskell-mode-map "\177" 'backward-delete-char-untabify) -(define-key haskell-mode-map "\M-\C-\177" 'delete-horizontal-space) - -(defun haskell-set-local-vars () - "Set the local variables for haskell-mode." - (kill-all-local-variables) - - (setq indent-line-function 'haskell-indent-line) - - (make-local-variable 'haskell-std-list-indent) - ;;Non-nil means indent to the offset, 'haskell-list-offset' in a bracket rather than - ;; moving to the next word afer a function name - (setq haskell-std-list-indent t) - - (make-local-variable 'haskell-nest-ifs) - ;;Non-nil means that 'if' statements are nested ie. lined up with `if' not `else'. - (setq haskell-nest-ifs nil) - - (make-local-variable 'haskell-align-else-with-then) - ;;Non-nil means align an `else' under it's corresponding `then' - (setq haskell-align-else-with-then nil) - - - ;;The local vars for 'where' indentation - - (make-local-variable 'haskell-align-where-with-eq) - ;;Non-nil means align a 'where' under it's corresponding equals sign - (setq haskell-align-where-with-eq t) - - (make-local-variable 'haskell-align-where-after-eq) - ;;Non-nil means align a 'where' after it's corresponding equals sign - (setq haskell-align-where-after-eq nil) - - (make-local-variable 'haskell-std-indent-where) - ;;put the 'where' the standard offset ie. 'haskell-indent-offset' - (setq haskell-std-indent-where nil) - - - (make-local-variable 'haskell-always-fixup-comment-space) - ;;Non-nil means always insert a (single) space after a comment, even - ;; if there is more or less than one. - (setq haskell-always-fixup-comment-space t) - - - (make-local-variable 'haskell-indent-offset) - ;;Extra indentation for a line continued after a keyword. - (setq haskell-indent-offset 4) - - (make-local-variable 'haskell-list-offset) - ;;Extra indentation for continuing a list. - (setq haskell-list-offset 4) - - (make-local-variable 'haskell-comp-offset) - ;;Extra indentation for a list comprehension. - (setq haskell-comp-offset 4) - - (make-local-variable 'haskell-case-offset) - (setq haskell-case-offset 4) - - (make-local-variable 'haskell-where-offset) - (setq haskell-where-offset 4) - - (make-local-variable 'haskell-let-offset) - (setq haskell-let-offset 4) - - (make-local-variable 'haskell-then-offset) - (setq haskell-then-offset 0) - - (make-local-variable 'haskell-if-offset) - (setq haskell-if-offset 4) - - (make-local-variable 'haskell-comment-column) - (setq haskell-comment-column 35) - - (make-local-variable 'haskell-concat-column) - (setq haskell-concat-column 69) - - (make-local-variable 'haskell-where-threshold) - (setq haskell-where-threshold 35) - - (make-local-variable 'line-comment) - (setq line-comment "-- ") - - (make-local-variable 'haskell-indent-style) - (setq haskell-indent-style "none")) - - -(defun haskell-set-syntax-table () - "Set the syntax table for Haskell-mode." - (setq haskell-mode-syntax-table (make-syntax-table)) - (set-syntax-table haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"") - (modify-syntax-entry ?\\ "\\") - (modify-syntax-entry ?\' "w") - (modify-syntax-entry ?_ "w") - (modify-syntax-entry ?# "_") - (modify-syntax-entry ?$ "_") - (modify-syntax-entry ?% "_") - (modify-syntax-entry ?: "_") - (modify-syntax-entry ?? "_") - (modify-syntax-entry ?@ "_") - (modify-syntax-entry ?! "_") - (modify-syntax-entry ?^ "_") - (modify-syntax-entry ?~ "_") - (modify-syntax-entry ?- "_ 12") - (modify-syntax-entry ?\n ">") - (modify-syntax-entry ?{ "(}") - (modify-syntax-entry ?} "){") - (set-syntax-table haskell-mode-syntax-table)) - - - -(defun haskell-mode () - "Major mode for editing Haskell code. -Linefeed reindents current line, takes newline and indents. -Tab indents current line for Haskell code. -Functions are seperated by blank lines. -Delete converts tabs to spaces as it moves back. -\\{haskell-mode-map} -Variables controlling indentation style: - haskell-indent-offset - Standard extra indentation for continuing Haskell - code under the scope of an expression. The default is 4. - - haskell-list-offset - Extra indentation for indenting in a list. Used if variable - haskell-std-list-indent is non-nil. The default is 4. - - haskell-comp-offset - Extra indentation for continuing a list comprehension. - The default is 4. - - haskell-case-offset - Standard extra indentation for continuing Haskell - code under the scope of an expression. The default is 4. - - haskell-where-offset - Standard extra indentation for continuing Haskell - code under the scope of a `where'. The default is 4. - - haskell-let-offset - Standard extra indentation for continuing Haskell - code under the scope of a `let'. The default is 4. - - haskell-then-offset - Standard extra indentation for a `then' beyond - its corresponding `if'. The default is 0. - - haskell-if-offset - Standard extra indentation for continuing Haskell - code under the scope of an `if'. The default is 4. - - haskell-comment-column - Column to which line comments `--' will be inserted. - The default is 35. - - haskell-concat-column - Column to which concatenation operator `++' will be inserted. - The default is 69. - - haskell-where-threshold - Column beyond which a `where' will be indented to the - start of a line (to avoid spilling over lines). - The default is 35. - - set-haskell-indent-offset (C-c i) - Changes the default value of the local variable, - haskell-indent-offset. May be a number from 0-10. - - set-haskell-list-indent (C-c l) - Change the value of the local variable, - haskell-list-offset. May be a number from 0-100. - - set-haskell-comment-column (C-x ;) - Changes the value of the local variable, - haskell-comment-column. May be any number from 0-100." - - (interactive) - (haskell-set-local-vars) - (haskell-set-syntax-table) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ())) - - - - -;;; Returns the indentation column for a comment on this line. -;;; The point is positioned at the last char of any code on the line. - -(defun haskell-comment-indent () - "Returns the indentation for a comment on the given line. -If the line has code on it or the point is not at the beginning of the line, -then indent to indent-column. -Otherwise, don't indent." - (cond ((or (haskell-code-on-linep) - (not (bolp))) - ;;There is code before the haskell-comment-column - ;; or not at the beginning of the line - ;;Return the largest of - ;; the current column +1 and the haskell-comment-column - (max (1+ (current-column)) - haskell-comment-column)) - (t - ;;Otherwise, return 0 - 0))) - - - -;;; Returns whether a comment is on the current line -;;; Search from bol, and beware of "--", {-- etc! -;;; DOES NOT RECOGNISE {- COMMENTS YET or -- within a string - -(defun haskell-comment-on-linep () - "Returns the truth value of whether there is a '--' comment on the current line." - (save-excursion - (beginning-of-line) - (looking-at ".*--"))) - - -;;; This doesn't account for comments '{-'. Test explicitly if you use this function! - -(defun haskell-code-on-linep () - "Returns a truth value as to whether there is code on the current line." - (save-excursion - (beginning-of-line) - (not - ;; Code on line if not looking at a comment directly - ;; and the line is not blank - (or - (looking-at "^[ \t]*--") - (looking-at "^[ \t]*$"))))) - - -;;; Insert a Haskell "--" comment on the current line. -;;; Move to the comment position if there's already a comment here. -;;; Otherwise, the comment is inserted either at the comment column -;;; or one column after the last non-space character, whichever is further -;;; to the right. -;;; This function is executed by M-; - -(defun haskell-insert-comment () - "Inserts a '--' comment on the given line." - (interactive) - (cond ((haskell-comment-on-linep) - ;;There is a comment on the line - ;;Just reindent existing comment - (haskell-reindent-comment)) - (t - (if (haskell-code-on-linep) - ;;There is code on the line - ;; and guarenteed that a comment - ;; does not already exist. - ;;Move to the last nonspace char - ;; (there may be spaces after the last char) - (progn - (end-of-line) - (skip-chars-backward " \t"))) - ;;Indent to required level - ;; and insert the line comment '--' - (indent-to (haskell-comment-indent)) - (insert line-comment)))) - - -;;; Reindents a comment. -;;; The comment is indented according to the normal rules. -;;; Skips over ---- and following spaces or tabs - -(defun haskell-reindent-comment () - "Indents a comment on a line to keep it at haskell-comment-column, -if possible. -It is guaranteed that a comment exists on the current line." - (beginning-of-line) - ;;Go back to beginning of comment - (re-search-forward "--") - (forward-char -2) - ;;Delete all spaces and reindent to - ;; the correct location. - (delete-horizontal-space) - (indent-to (haskell-comment-indent)) - ;;Move past the comment and insert - ;; only one space between it and the text. - ;;Leave point just after comment. - (skip-chars-forward "- \t") - (if haskell-always-fixup-comment-space - (progn - (fixup-whitespace) - (forward-char 1)))) - - - -;;; Inserts a haskell concatenation operator, `++', at the -;;; column dictated by haskell-concat-column - -(defun haskell-insert-concat() - "Inserts a `++' operator on the given line." - (interactive) - (end-of-line) - (skip-chars-backward " \t") - ;;Indent to required level - ;; and insert the concat operator `++' - (indent-to (haskell-concat-indent)) - (insert "++")) - - - -;;; Returns the indentation column for a concatenation operator on this line. -;;; The point is positioned at the last char of any code on the line. - -(defun haskell-concat-indent () - "Returns the indentation for a concat operator on the given line." - (max (1+ (current-column)) - haskell-concat-column)) - - - -;;; Returns the indentation of the current line of haskell code. -;;; A blank line has ZERO indentation - -(defun haskell-current-indentation () - "Returns the indentation for the current haskell line. A blank line has -indentation zero." - (save-excursion - (beginning-of-line) - (if (looking-at "^[ \t]*$") - ;;The line is empty - ;; so the indentation is zero - 0 - ;;Otherwise find the normal value of indentation - (current-indentation)))) - - - -;;; Returns the indentation of the previous line of haskell code. -;;; A blank line has ZERO indentation - -(defun haskell-previous-indentation () - "Returns the previous line's indentation as Haskell indentation." - (save-excursion - (if (not (bobp)) - ;;Not at the start of the buffer - ;; so get the previous lines indentation - (progn - (forward-line -1) - (haskell-current-indentation)) - ;;We are at the start of buffer - ;;There is no previous line; Indent is zero - 0))) - - - -;;; Move back to the last line which is aligned in the left column. -;;; Ignores comments and blank lines. -;;; The point is left at the beginning of the line. - -(defun haskell-back-to-zero-indent () - "Moves point to last line which has zero as indentation." - ;;Not at the beginning of buffer. - ;;Continue to go to the previous line until - ;; we find a line whose indentation is non-zero. - ;;Blank lines and lines containing only comments - ;; are ignored. - (beginning-of-line) - (while (and - (or (not (zerop (haskell-current-indentation))) - (looking-at "^[ \t]*\\($\\|--\\)")) - (not (bobp))) - (haskell-backward-to-noncomment) - (beginning-of-line))) - - - -;;; Find the last symbol, usually an equality. - -;;; Note: we check for "=" as a complete WORD (and ignore -;;; comments) when searching for this. Ie. an `=' may be -;;; surrounded only by a letter, digit, or whitespace . -;;; Strings are not considered. -;;; Don't go beyond the first character in the (possibly narrowed) buffer. -;;; From the beginning of the line, -;;; find the comment position (or end-of-line) -;;; search forward to this position, looking for a "where" -;;; If one's found, then search forward for "\b=\b" -;;; If there's no equality sign then -;;; search forward from the start of the line for an equals -;;; Otherwise we found it. -;;; If there's no where then search forward for an equals, as above. - -(defun haskell-back-to-symbol (exp) - "Goes backward from point until a symbol, EXP, is found. -The point is left at the first symbol matching the context -of the haskell code." - (let* ((found nil) - (symbol (concat "[ \ta-z0-9A-Z]" exp "[ \t\na-z0-9A-Z]")) - eol-limit - bol-limit - (zero-indent (save-excursion - (haskell-back-to-zero-indent) - (point))) - (initial-depth (car (parse-partial-sexp - (point) - zero-indent)))) - - (while (and (not found) - (> (point) zero-indent)) - ;;Not found and point > point min - ;;Record the limit of search for the beginning and - ;; end of the line. - (setq eol-limit (point)) - (beginning-of-line) - (setq bol-limit (point)) - (goto-char eol-limit) - (re-search-backward "\\bwhere\\b" bol-limit 't) - ;;Search back from the end of the line - ;; to find the most recent 'where'. - - (cond ((and (re-search-backward symbol bol-limit 't) - (= initial-depth - (car (parse-partial-sexp - (point) - zero-indent)))) - ;;Found a symbol sign surrounded by - ;; a letter, digit or space only, or at the - ;; beginning of the buffer and they are at - ;; the same depth level - (setq found 't)) - ((and (re-search-backward symbol bol-limit 't) - (zerop - (car (parse-partial-sexp - (point) - zero-indent)))) - ;; Found a symbol and it is not in any parens - (setq found 't)) - ;;Otherwise, go back a line. - (t (haskell-backward-to-noncomment)))) - (if found - (forward-char 1)))) - - -;;; Goes back to the last keyword. The point is left at the -;;; beginning of the keyword. -;;; The words recognised are: -;;; `case',`of',`where',`let',`in',`if',`then',`else' - -(defun haskell-back-to-keyword () - "Goes backward from point until a keyword is found. -The point is left after the first keyword." - (let* ((found nil) - eol-limit - bol-limit - (zero-indent (save-excursion - (haskell-back-to-zero-indent) - (point))) - (initial-depth (car (parse-partial-sexp - (point) - zero-indent)))) - - (while (and (not found) - (>= (point) zero-indent)) - ;;Not found and point > point min - ;;Go back past any comment. - ;;Record the limit of search for the beginning and - ;; end of the line. - (setq eol-limit (point)) - (beginning-of-line) - (setq bol-limit (point)) - (goto-char eol-limit) - (if (and (re-search-backward - "\\b\\(case\\|of\\|where\\|let\\|in\\|if\\|then\\|else\\)\\b" - bol-limit 't) - (= initial-depth - (car (parse-partial-sexp - (point) - zero-indent)))) - ;;Found a keyword and it is at the same level as the initial position - (progn - (setq found 't) - (forward-word 1)) - ;;Otherwise, go back a line. - (haskell-backward-to-noncomment))))) - - - -;;; Returns the end of line (point) of the current line, excluding any -;;; line comments on it. - -(defun haskell-eol () - "Returns the end (point) of the current line, excluding any line comments." - (save-excursion - (end-of-line) - (let ((eol-limit (point))) - (beginning-of-line) - (if (search-forward "--" eol-limit 'move-to-eol) - ;;Found a '--' - ;;So move to the beginning of the comment - ;;If fail then move to end of line - (forward-char -2))) - (point))) - - - -;;; Returns whether or not the current line contains an equality outwith a -;;; comment. The equality may only be surrounded by a letter, digit or -;;; whitespace. - -(defun haskell-looking-at-eqp () - "Returns whether or not the current line contains an equality outwith a -comment." - (save-excursion - (beginning-of-line) - (re-search-forward "[ \ta-z0-9A-Z]=[ \t\na-z0-9A-Z]" (1+ (haskell-eol)) 't))) - - -;;; This function does not require all keywords, just those which -;;; may have a bracket before them. -(defun haskell-looking-at-keywordp () - "Returns whether or not there is a keyword after the point outwith a -comment." - (save-excursion - (re-search-forward - "\\(\\(=>\\|=\\|++\\|->\\|<-\\|::\\)\\|\\b\\(case\\|of\\|if\\|then\\|else\\|let\\|in\\)\\b\\)" - (haskell-eol) 't))) - - -;;; This function returns whether or not there is a keyword contained in -;;; the region START END. START < END. - -(defun haskell-keyword-in-regionp (start end) - "Returns whether or not there is a keyword between START and END." - (save-excursion - (goto-char start) - (let ((found nil) - (eol-limit (haskell-eol))) - (while (and (not found) (< (point) end)) - (if (> eol-limit end) - (setq eol-limit end)) - (if (re-search-forward - "\\b\\(case\\|of\\|if\\|then\\|else\\|let\\|in\\)\\b" - eol-limit 'move) - (setq found t) - ;;Otherwise, have not found a keyword. Now at haskell-eol. - (if (< (point) end) - ;;We still have an area to search - ;; so go forward one line - (progn - (beginning-of-line) - (forward-line 1) - (setq eol-limit (haskell-eol)))))) - ;;found is `t' or point >= end - found))) - - -;;; Goes back to the last line which is not entirely commented out. -;;; The point is left just before the comment. - -(defun haskell-backward-to-noncomment () - "Sets the point to the last char on the line of Haskell code before a comment." - (let ((comment 't) - (limit (point-min))) - (while (and comment (> (point) limit)) - ;; comment is true and point > limit - (beginning-of-line) - (if (< (forward-line -1) 0) - ;;This was the first line in the buffer - (setq comment nil) - ;;Otherwise, this was not the first line - (if (not (looking-at "^[ \t]*\\($\\|--\\)")) - ;;There is not a comment at the beginning of the line - ;; and the line is not blank - (progn - ;;The line is either blank or has code on it. - (setq comment nil) - (goto-char (haskell-eol)))))) - - ;;return point - (point))) - - - -;;; Indents a region (by applying "tab" to each line). -;;; The marker upper-marker is set to the end of the region. -;;; We indent from the beginning of the region to this marker. -;;; Implements C-c r. - -(defun haskell-indent-region () - "Indents the region between the point and mark." - (interactive) - (let ((lower-limit (min (point) (mark))) - (upper-limit (max (point) (mark)))) - (indent-region lower-limit upper-limit 'nil))) - - - -;;; Implements TAB. -;;; This actually indents a line. -;;; Eventually it will handle a line split at any point, - -(defun haskell-indent-line () - "Indent current line as Haskell code. -Keeps the point at the same position on the line unless the -point is less then the current indentation, in which case the -point is moved to the first char." - (interactive) - (save-excursion - (let ((indent (haskell-calculate-indentation))) - (beginning-of-line) - (delete-horizontal-space) - ;;Kill any spaces that may preceed the code - ;; and reindent to the correct level. - (indent-to indent))) - (if (< (current-column) (current-indentation)) - ;;The point is in the indentation - ;; so move to the first char on the line - (move-to-column (current-indentation)))) - - - -;;; This is the haskell version of the Emacs function -;;; reindent-then-newline-and-indent. It was necessary -;;; to write this because the Emacs version has the -;;; terrible property of deleting whitespace BEFORE -;;; reindenting the original line. - -(defun haskell-reindent-then-newline-and-indent () - "Reidents the current line of Haskell code then takes a -newline and indents this new line." - (interactive) - (skip-chars-backward " \t") - (haskell-indent-line) - (newline) - (delete-horizontal-space) - (haskell-indent-line)) - - - -;;; Returns whether the first word of the last line with zero indentation -;;; is the same as the first word of the current line. -;;; This function is based on the (reasonable?) assumption that -;;; a function definition occurs on the left hand margin. -;;; This is not quit reasonable since recusive functions are not -;;; recognised. - -(defun haskell-continued-fn-defp () - "Returns whether the first word on the last line with zero indentation -matches the first word on the current line." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - ;;Goto the first non space char - (haskell-word-eq (point) - (save-excursion - (forward-line -1) - (haskell-back-to-zero-indent) - (point))))) - - -;;; Returns whether two words are the same. -;;; The beginning of both words are given as their -;;; respective points in the buffer. - -(defun haskell-word-eq (current-pos previous-pos) - (let ((OK 't)) - (goto-char previous-pos) - ;;We shall compare the two words starting - ;; at previous-pos and current-pos. - (while (and OK (looking-at "\\S-")) - ;;OK and looking at a word constituent - (if (eq (char-after current-pos) - (char-after previous-pos)) - ;;The two chars are the same - (progn - ;;Increment the two postions - ;; and update location of point - (setq current-pos (1+ current-pos)) - (setq previous-pos (1+ previous-pos)) - (goto-char previous-pos)) - ;;The two chars are different - ;; so set OK to be false - (setq OK 'nil))) - - ;;Return the value of OK - OK)) - - - - -;;; This function returns the column of the last unbalanced -;;; expression. -;;; It is called when an keyword is found. The point is -;;; initially placed before the corresponding keyword. -;;; The function looks at every word to see if it is a -;;; `let' or `in'. Each word must be outwith a comment. - -(defun haskell-last-unbalanced-key-column (open close) - "Returns the column of the last unbalanced keyword, open." - (save-excursion - (let ((original-pos (point)) - (bol-limit (save-excursion - (beginning-of-line) - (setq bol-limit (point)))) - (depth 1)) - (setq open (concat "\\b" open "\\b")) - (setq close (concat "\\b" close "\\b")) - (while (and - (> depth 0) - (> (point) (point-min))) - (forward-word -1) - (if (< (point) bol-limit) - ;;Moved past the beginning of line limit - ;; so go back to the previous line past - ;; any comments. - (progn - (goto-char original-pos) - (haskell-backward-to-noncomment) - (setq original-pos (point)) - (setq bol-limit (save-excursion - (beginning-of-line) - (point)))) - ;;Otherwise, still on the same line - (if (looking-at open) - ;;This word is an open keyword - (setq depth (1- depth)) - ;;Otherwise, - (if (looking-at close) - ;;This word is a close keyword - (setq depth (1+ depth)))))) - - (if (string= open "\\bif\\b") - ;;The argument is `if' - (if (not (save-excursion (skip-chars-backward " \t") (bolp))) - ;;There is something before the `if' - (if (and (save-excursion - (forward-word -1) - (looking-at "\\belse\\b")) - (not haskell-nest-ifs)) - ;;There is an `else' before the 'if' - (forward-word -1)))) - - - (current-column)))) - - - -;;; Return the indentation for a line given that we expect a `where'. -;;; The point lies on the corresponding symbol -;;; that the `where' scopes over. - -(defun haskell-indent-where () - "Return the indentation for a line, given that we expect a `where' -clause." - (let ((symbol (if (looking-at "=") - "=" - "->"))) - - (cond ((or haskell-std-indent-where - (> (current-column) haskell-where-threshold)) - ;;Set indentation as the sum of the previous - ;; line's layout column and the standard offset - ;; (ie. 'haskell-where-offset) - (save-excursion - (beginning-of-line) - (cond ((looking-at (concat "^[ \t]*" symbol)) - ;;The line starts with the symbol - (setq indent (current-indentation))) - ((looking-at "^[ \t]*where\\b") - ;;The line starts with a 'where' - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (+ (current-column) haskell-where-offset))) - (t - ;;The line begins on the layout column - (setq indent (+ (current-indentation) - haskell-indent-offset)))))) - ((or haskell-align-where-with-eq - haskell-align-where-after-eq) - (if (looking-at (concat symbol "[ \t]*$")) - ;;The symbol is at the end of the line - (setq indent (+ (current-indentation) - haskell-where-offset)) - (save-excursion - ;;Set the indentation as required - (if haskell-align-where-after-eq - (skip-chars-forward (concat symbol " \t"))) - (setq indent (current-column)))))))) - - - -;;; Calculates the indentation for the current line. -;;; When we come here, we are in a line which we want to indent. -;;; We should leave the point at the same relative position it -;;; was in before we called the function, that is, if a line -;;; is already correctly indented, nothing happens! - -;;; The main problems are handling "where" definitions -;;; and the syntax of expressions when these are continued -;;; over multiple lines (e.g. tuples, lists, or just plain -;;; bracketed expressions). Watch out for let ... in, too! - -;;; For example, think about the following tricky cases: - -;;; f x = x + <NL> - -;;; f x = [ x + y, <NL> - -;;; f x = [ <NL> - -;;; f x = [ -- start of a large list -;;; -- which I'm commenting in as I go -;;; <TAB> - -(defun haskell-calculate-indentation () - "Returns the indentation level for the current line of haskell code." - (save-excursion - (let ((indent 0) - (eol-position (point))) - (beginning-of-line) - (cond ((bobp) - ;;We are at the beginning of the buffer so do nothing at all - (setq indent 0)) - - ((looking-at "^[ \t]*--") - ;;There is a comment on the line by itself - ;;Leave it the way it is - (setq indent (current-indentation))) - - ((looking-at "^[ \t]*\\(data\\|type\\|module\\|import\\|instance\\)\\b") - ;;There is a 'data', 'type', 'module' or 'import' at start of line - (setq indent 0)) - - ((haskell-continued-fn-defp) - ;;This is clearly same function - ;; so set indent to be 0 - (setq indent 0)) - - ((looking-at "^[ \t]*[]}]") - ;;There is a "]" or "}" at the start of the line - (let ((state (parse-partial-sexp (match-end 0) - (save-excursion - (haskell-back-to-zero-indent) - (point))))) - (if (>= (car state) 0) - ;;Since the point is just after a parenthesis - ;; it has a match if the depth is >= 0 - (save-excursion - (goto-char (nth 2 state)) - ;;Move to the match. - (if (not - (save-excursion - (skip-chars-backward " \t") - (bolp))) - ;;There is something before the brace. - (progn - (let ((initial-pos (point))) - (forward-word -1) - (if (not (looking-at - "\\(let\\|where\\)")) - ;;The word is not `where' or `let' - ;; so go back. - (progn - (goto-char initial-pos) - (skip-chars-forward " \t")))))) - (setq indent (current-column))) - (setq indent 0)))) - - ((looking-at "^[ \t]*\\(->\\|=>\\)") - ;; '->' or '=>' at start of line - (save-excursion - (haskell-backward-to-noncomment) - ;;Go back to previous line - (let ((eol-limit (point))) - (beginning-of-line) - (if (re-search-forward "::" eol-limit 't) - ;;There is a '::' on this (previous) line - ;; set indent to be at the start of it - (setq indent (- (current-column) 2)) - ;;Otherwise copy this (previous) line's indentation - (setq indent (current-indentation)))))) - - ((looking-at "^[ \t]*where\\b") - ;;There is a 'where' at the start of the line - ;;Look for the equality (which will not - ;; be on this line). - (haskell-backward-to-noncomment) - (goto-char (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-symbol "->") - (point)))) - (setq indent (haskell-indent-where))) - - ((looking-at "^[ \t]*then\\b") - ;;The first thing on the line is a `then' - (setq indent (+ (haskell-last-unbalanced-key-column "if" "then") - haskell-then-offset))) - - ((looking-at "^[ \t]*else\\b") - ;;The first thing on the line is a `else' - (if haskell-align-else-with-then - (setq indent (haskell-last-unbalanced-key-column "then" "else")) - (setq indent (haskell-last-unbalanced-key-column "if" "else")))) - - ((looking-at "^[ \t]*|") - ;;There is a `|' at beginning of line - (save-excursion - (let ((state - (parse-partial-sexp (save-excursion - (haskell-back-to-zero-indent) - (point)) - (point)))) - (if (not (or (nth 3 state) (nth 4 state))) - ;;Not in a comment or string - (if (> (car state) 0) - ;;In an unbalanced parenthesis. - (progn - (goto-char (nth 1 state)) - ;;Move to the beginning of the unbalanced parentheses - (if (and (looking-at "\\[") - (search-forward "|" (haskell-eol) 't)) - ;;It is a list comprehension - (setq indent (1- (current-column))) - (setq indent (+ (current-column) - haskell-comp-offset)))) - ;;Otherwise, not in an unbalanced parenthesis - (setq indent (save-excursion - (haskell-back-to-symbol "=") - (cond ((not (looking-at "=")) - ;;Did not find an equals - (+ (haskell-previous-indentation) - haskell-indent-offset)) - ((save-excursion - (beginning-of-line) - (looking-at "^[ \t]*data\\b")) - ;;There is a `data' at beginning - (setq indent (current-column))) - ((save-excursion - (beginning-of-line) - (search-forward - "|" (haskell-eol) 't)) - ;;There is a `|' on this line - ;; so set this to be the indent - (save-excursion - (goto-char (match-beginning 0)) - (current-column))) - (t - ;;Otherwise, set `=' as indent - (current-column)))))))))) - - ((looking-at "^[ \t]*=") - ;;There is an equals at the start of the line - ;;Set the indentation to be the previous line's - ;; indentation plus the standard offset - (setq indent (+ haskell-indent-offset - (haskell-previous-indentation)))) - - ((looking-at "^[ \t]*in\\b") - ;;The line starts with 'in' - (beginning-of-line) - (setq indent (haskell-last-unbalanced-key-column "let" "in"))) - - ((looking-at "^[ \t]*of\\b") - ;;The line starts with `of' - (beginning-of-line) - (setq indent (haskell-last-unbalanced-key-column "case" "of"))) - - ((looking-at "^.*::") - ;;There is a '::' in the line - ;;There are several possibilities for indentation - (if (looking-at "[ \t]*::") - ;;The '::' is the first thing on the line - ;; so set indent to be the previous line's - ;; indentation plus the standard offset - (setq indent (+ (haskell-previous-indentation) - haskell-indent-offset)) - (save-excursion - ;;Otherwise, the '::' is contained in the line somewhere - ;; so use contextual indentation - (setq indent (haskell-context-indent))))) - - (t - ;;Do not recognise the first word on the line. - (setq indent (haskell-context-indent)))) - - indent))) ;return indent as indentation value - - - -;;; Returns the indentation for the current line by looking at the -;;; previous line to give clues to the indentation. - -(defun haskell-context-indent () - "Returns the indentation for the current line by looking at -the previous line to dictate the indentation." - (save-excursion - (let ((original-position (point)) - indent) - (beginning-of-line) - (if (bobp) - ;;At the beginning of the buffer - (setq indent 0) - ;;Otherwise, we are not at the beginning of the buffer - (haskell-backward-to-noncomment) - (let ((eol-limit (point)) - ;;Record the (upper) limit for any search on this line - bol-limit - (paren-indent 'nil)) - ;;`paren-indent' flags whether we are indenting a list or not - (beginning-of-line) - (setq bol-limit (point)) - ;;Record the (lower) limit for any search on this line - (goto-char eol-limit) ;goto the end of the line - (flag) - (if (save-excursion - (goto-char eol-limit) - (and (re-search-backward - "[])][^][()]*" bol-limit 't) - (save-excursion - (goto-char (match-beginning 0)) - (not (haskell-looking-at-keywordp))))) - - ;;There is a close parenthesis at the end of the line - ;; followed by anything except "(", ")", "[", "]" - ;; or a keyword - (progn - ;;Search back for the close parenthesis - ;; and move to just after it. - (re-search-backward "[])]" bol-limit 't) - (forward-char 1) - (let ((state - (parse-partial-sexp (save-excursion - (haskell-back-to-zero-indent) - (point)) - (point)))) - (if (not (or (nth 3 state) (nth 4 state))) - ;;Not in a comment or string - (if (>= (car state) 0) - ;;The parenthesis has a match - (progn - (goto-char (nth 2 state)) - ;;Move to the beginning of the parentheses - ;; as this new line will determine - ;; further indentation - (if (zerop (car state)) - ;;This paren closes all unbalanced parens - ;; so move to - ;; the eol of last line with an equality. - (progn - (setq eol-limit (point)) - (goto-char - (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-keyword) - (point)))) - (goto-char eol-limit)) - ;;esle just go to the end of the line - (goto-char (haskell-eol))) - (setq paren-indent 't) - ;;Set 'paren-indent' to true to indicate we - ;; are indenting a list. - (setq eol-limit (point)) - (beginning-of-line) - (setq bol-limit (point)) - ;;Reduce the scope of any later - ;; indentation to - ;; exclude the balanced parentheses - ;; by making this point - ;; be the eol-limit. - (goto-char eol-limit))))))) - (flag) - ;;This cond expression is structured, to an - ;; extent, such that the keywords with highest - ;; indentation precedence come first. Order is important. - ;;In each condition, the point of match is noted so - ;; that we can see if this point is in a string. - (let ((indent-point (point))) - (cond ((re-search-backward "\\bof\\b" bol-limit 't) - ;; `of' is contained in previous line - (setq indent-point (point)) - (if (looking-at "of[ \t]*$") - ;;`of' at end of line - (setq indent (+ (haskell-last-unbalanced-key-column - "case" "of") - haskell-case-offset)) - ;;Otherwise, `of' is in line - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column)) - (setq indent (list indent)))) - - ((re-search-backward - "\\bthen[ \t]*$" bol-limit 't) - ;;There is a `then' at the end of the line. - (setq indent-point (point)) - (if haskell-align-else-with-then - ;;We want to align the `else' (to follow) with the `then' - (setq indent (+ (current-column) - haskell-if-offset)) - (setq indent (+ (haskell-last-unbalanced-key-column - "if" "then") - haskell-if-offset)))) - ;; This was here but don't know why (setq indent (list indent)))) - - ((save-excursion - (and (re-search-backward "\\bif\\b" bol-limit 't) - (setq indent-point (point)) - (not (re-search-forward "\\bthen\\b" eol-limit 't)))) - ;;There is an `if' on the (previous) line and the line does - ;; not have a `then' on it. - (setq indent (+ (haskell-last-unbalanced-key-column - "if" "then") - haskell-then-offset))) - - ((save-excursion - (and (re-search-backward "\\bif\\b" bol-limit 't) - (setq indent-point (point)) - (not (re-search-forward "\\belse\\b" eol-limit 't)))) - ;;There is an `if' on the (previous) line (the line may - ;; have a `then' on it) and does not have an else on it. - (if (re-search-backward "\\bthen\\b" bol-limit 't) - ;;There is a then on the line and it is followed by - ;; some code. - (progn - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - (if haskell-align-else-with-then - ;;We want to align the `else' with the `then' - (setq indent (haskell-last-unbalanced-key-column - "then" "else")) - (setq indent (haskell-last-unbalanced-key-column - "if" "else"))))) - - ((re-search-backward "\\b\\(let\\|in\\)\\b" bol-limit 't) - ;; 'let' or 'in' is contained in the (previous) line - (setq indent-point (point)) - (forward-word 1) ;skip past the word - (skip-chars-forward " \t{") - (if (looking-at "\\($\\|--\\)") - ;;looking-at eol or comment - (progn - (forward-word -1) - (setq indent (+ (current-column) - haskell-let-offset))) - (setq indent (current-column)))) - - ((re-search-backward - "\\belse[ \t]*$" bol-limit 't) - ;;There is a `else' at end of line - (setq indent-point (point)) - (save-excursion - (goto-char eol-limit) - (forward-word -1) - (setq indent (+ (current-column) - haskell-if-offset)))) - - ((re-search-backward - "\\belse\\b" bol-limit 't) - ;;There is a `else' on the line with no if or then - (setq indent-point (point)) - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column)))) - - ((save-excursion - (beginning-of-line) - (looking-at - "^[ \t]*then\\b")) - ;;There is a 'then' at beginning of line - (setq indent-point (point)) - (setq indent (current-indentation))) - - ((save-excursion - (beginning-of-line) - (looking-at "^[ \t]*else[ \t]*if\\b")) - (setq indent-point (point)) - ;;There is an 'else if' at start of (previous) line - (save-excursion - (beginning-of-line) - (if haskell-nest-ifs - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - (skip-chars-forward " \t") - (setq indent (current-column))))) - - ((re-search-backward "\\bcase\\b" bol-limit 't) - ;;There is a 'case' on the previous line - ;; so copy this line's indentation and add on - ;; the offset unless there is not an of. - (setq indent-point (point)) - (setq indent (+ (current-column) - haskell-case-offset))) - - ((save-excursion - (beginning-of-line) - (looking-at "^\\(instance\\|class\\)\\b")) - ;;This (previous) line has an 'instance' or 'class' at start - ;; so just set indentation to be this line indentation - ;; plus the standard offset - (setq indent-point (point)) - (setq indent (+ (current-indentation) - haskell-indent-offset))) - - ((re-search-backward "where\\b" bol-limit 't) - ;;There is a 'where' on the (previous) line - (setq indent-point (point)) - (if (looking-at "where[ \t]*$") - ;;There is nothing after the 'where' - ;; so set indent to be this column - ;; (ie. the column of the 'w') - ;; plus the standard offset - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - ;;The 'where' is the only thing on the line. - (setq indent (+ (current-column) - haskell-where-offset)) - ;;Otherwise, the 'where' is at the end - ;; of the line and there is code before it. - ;;Look before the 'where' for the symbol - ;; it scopes over. - (forward-word -1) - (goto-char (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-symbol "->") - (point)))) - (setq indent (haskell-indent-where))) - - ;;Otherwise, go past the 'where' - ;; and goto the last non space character. - ;;Set this column to be the indentation. - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column)))) - - ((re-search-backward - "[ \ta-z0-9A-Z]=[ \t]*$" bol-limit 't) - ;;There is an equals is at the end of line - ;; so make the indentation be this line's indentation - ;; plus the standard offset - (setq indent-point (point)) - (setq indent (+ (current-indentation) - haskell-indent-offset))) - - ((re-search-backward - "[ \ta-z0-9A-Z]\\+\\+[ \t]*$" bol-limit 't) - ;;There is a concat operator at the end of line - ;; so make the indentation be this line's indentation - (setq indent-point (point)) - (setq indent (current-indentation))) - - ((save-excursion - (beginning-of-line) - (looking-at - "^[ \t]*=[ \ta-z0-9A-Z]")) - ;;There is an equals is at the beginning of line - ;; so make the indentation be the previous line's - ;; indentation unless the previous line's - ;; indentation is zero. - (setq indent-point (point)) - (save-excursion - (haskell-backward-to-noncomment) - (if (zerop (current-indentation)) - (setq indent (+ (current-indentation) - haskell-indent-offset)) - (setq indent (haskell-current-indentation))))) - - ((re-search-backward "|" bol-limit 't) - ;;There is an `|' on this line. - (setq indent-point (point)) - (if (save-excursion - (goto-char original-position) - (looking-at "^[ \t]*\\($\\|--\\||\\)")) - ;;The original line is empty or has a `|' at the - ;; start. So set indent to be first `|' on this line - (save-excursion - (goto-char bol-limit) - (re-search-forward "|" eol-limit 't) - (setq indent (1- (current-column)))) - ;;Otherwise set indent to be this (previous) line's - (setq indent 0))) - - ((re-search-backward "->" bol-limit 't) - ;;There is a `->' in the line. - ;;This may be from a `case' or a - ;; type declaration. - (setq indent-point (point)) - (save-excursion - (if (re-search-backward "::" bol-limit 't) - ;;There is a '::' on this line - (if (looking-at ".*->[ \t]*$") - ;;The '->' is at the end of line. - ;;Move past the '::' and any spaces - ;; and set indent to be this column. - (progn - (skip-chars-forward ": \t") - (setq indent (current-column))) - ;;Otherwise, the '->' is not at end of line - ;; so copy the indentation - (setq indent (haskell-context-indent))) - - ;;Otherwise, there is not a - ;; `::' on this line so copy this - ;; (previous) indentation. - (setq indent (haskell-context-indent))))) - - ((re-search-backward "::" bol-limit 't) - ;;There is an '::' on this line. - ;;We know that the line does not end with '->'. - (setq indent-point (point)) - (if (looking-at "::[ \t]*$") - ;;The '::' is at the end of the line - ;; so set indent to be this line's - ;; indentation plus the offset. - (setq indent (+ (current-indentation) - haskell-indent-offset)) - ;;Otherwise the `::' is in the line - (setq indent (current-indentation)))) - - ((re-search-backward - "\\b\\(import\\|class\\)\\b" - bol-limit 't) - ;;There is an `import' or `class' on the line. - ;;Copy this indentation. - (setq indent-point (point)) - (setq indent (current-indentation))) - - ((or - (haskell-looking-at-eqp) - (save-excursion - (beginning-of-line) - (looking-at "^[ \t]*$"))) - ;;There is an '=' on the line - ;; or it is blank - (setq indent-point (point)) - (cond ((save-excursion - (beginning-of-line) - (looking-at "^[ \t]*data\\b")) - ;;`data' at start of line - ;; so expect a `|' - (haskell-back-to-symbol "=") - (setq indent (current-column))) - ((zerop (current-indentation)) - ;;If the indentation is zero, we expect a `where' - (goto-char eol-limit) - (haskell-back-to-symbol "=") - (setq indent (haskell-indent-where))) - ((looking-at "^[ \t]*=[ \t\na-z0-9A-Z]") - ;;The equality is the first thing on the line - ;; so copy the last lines indentation - (save-excursion - (haskell-backward-to-noncomment) - (setq indent (current-indentation)))) - (t - ;;Otherwise, copy the indentation - (setq indent (current-indentation))))) - - ((save-excursion - (beginning-of-line) - (and (zerop (current-indentation)) - (not (looking-at "^[ \t]*$")))) - ;;The line is not blank and its indentation is zero - ;;It is a function definition. We know that - ;; there is not an equals on the line - (goto-char eol-limit) - ;;We expect a keyword - ;; so set indent to be this line's indentation - ;; plus the offset - (setq indent-point (point)) - (setq indent (+ (current-indentation) - haskell-indent-offset))) - - ((bobp) - ;;At the beginning of buffer - (setq indent 0)) - - (paren-indent - ;;We are indenting a list and none - ;; of the above indentations are applicable - ;; so copy the indentation of this line - (setq indent (current-indentation))) - - (t - (save-excursion - (setq indent (haskell-context-indent))))) - - (if (nth 3 (parse-partial-sexp - (save-excursion - (goto-char indent-point) - (haskell-back-to-zero-indent) - (point)) - (save-excursion - (goto-char indent-point)))) - ;;The point we determined indentation at is in a - ;; string so go to this point and go back one line to - ;; find indentation. - (setq indent (haskell-context-indent)))) - - - ;;HOWEVER, we may have to override any indentation if we are in - ;; an unbalanced parenthesis (on the original line). - (flag) - (save-excursion - (goto-char original-position) - (let* ((eq-point (save-excursion - (haskell-back-to-symbol "=") - (point))) - (state (parse-partial-sexp - eq-point - (point)))) - (if (> (car state) 0) - ;;There is an unbalanced parenthesis between - ;; the function and here. - (if (not (or (nth 3 state) (nth 4 state))) - ;;We are not in a string or comment - ;; so goto the parenthesis - (progn - (goto-char (nth 1 state)) - (if (not (haskell-keyword-in-regionp - (point) - original-position)) - ;;There is not a keyword after the open - ;; bracket so we override the indentation - (progn - (if (not (looking-at "{")) - ;;The parenthesis is not a `{' - (if (or (looking-at "\\[") - (save-excursion - (goto-char (haskell-eol)) - (skip-chars-backward " \t") - (and - (char-equal (preceding-char) ?,) - (= (car state) - (car (parse-partial-sexp - eq-point - (point))))))) - ;;The paren is a square one - ;; or it is a tuple. - ;;Don't ignore what is after it. - (setq indent (haskell-list-align (haskell-eol))) - ;;Otherwise, ignore what comes after it. - (setq indent (haskell-list-align (point)))))))))))) - )) - - indent))) - - -;;; Inserts the close parenthesis and reindents the line. -;;; We want to reindent the line if the parenthesis is -;;; the first character on the line. The parenthesis -;;; recognised by this function are `]', `}'. - -(defun electric-haskell-brace () - "Inserts the character `]' or `}' and reindents the current line." - "Insert character and correct line's indentation." - (interactive) - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - ;;The parenthesis is at the beginning of the line. - (progn - (insert last-command-char) - (haskell-indent-line)) - ;;Otherwise it is not at the beginning of line. - (insert last-command-char)) - ;; Match its beginning. - (haskell-blink-open)) - - - - -;;; This function returns the indentation for the next line given -;;; that it is contained in a bracket or we are extending a functions -;;; parameters over a line. For the case of being in an unbalanced -;;; parenthesis list, the point lies on the unbalanced parenthesis. -;;; The parameter eol-limit is used to delimit the end of the line. - -(defun haskell-list-align (eol-limit) - "Returns the indentation for the next line given that -the point lies on an unbalanced open parenthesis." - (save-excursion - (let ((indent (1+ (current-column)))) - ;;Set indent to be the next char (at least). - - (cond ((not - (looking-at ".[ \t]*\\($\\|--\\)")) - ;;There is something after the parenthesis - ;;ie. the line is not empty and ignore comments - (cond ((save-excursion - (goto-char eol-limit) - (skip-chars-backward " \t") - (and (char-equal (preceding-char) ?,) - (save-excursion - (beginning-of-line) - (not (search-forward "|" eol-limit 't))))) - ;;This is a normal list since a `,' at end - ;; and there is no a `|' on the line. - (forward-char 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - - ((looking-at "\\[") - ;;It is a list comp we are looking at - ;;Goto the bar. - (forward-char 1) - (search-forward "|" eol-limit 't) - (skip-chars-forward " \t") - (setq indent (current-column))) - - ((looking-at ".[ \t]*(") - ;;We are looking at an open parenthesis - ;; after this character. - ;;It must be balanced so - ;; move to the start of this paren - ;; and set indent to be here - (forward-char 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - - (t - (forward-word 1) - ;;We are not looking at another open - ;; parenthesis, so move forward past the - ;; (assumed) function name. - (if (or - haskell-std-list-indent - (looking-at"[ \t]*\\($\\|--\\)")) - ;;There is nothing after the name - ;; or haskell-std-list-offset is set - ;; so set indent to be its original - ;; value plus the offset minus 1 - ;; since we added one on earlier. - (setq indent - (+ indent - (1- haskell-list-offset))) - - ;;Otherwise there is something after the - ;; name, so skip to the first non space - ;; character. - (skip-chars-forward " \t") - (setq indent (current-column))))))) - - - indent))) - - - -(defun haskell-insert-round-paren () - "Inserts a `(' and blinks to its matching parenthesis." - (interactive) - (insert last-command-char) - (haskell-blink-open)) - - - -;;; This function is called when a close parenthesis -;;; `)', `]', or `}' is typed. -;;; Blinks the cursor on the corresponding open parnethesis. -;;; The point lies just after the close parenthesis. - -(defun haskell-blink-open () - "Blinks the cursor to the matching open parenthesis. -The point lies just after a parenthesis." - (let ((state (parse-partial-sexp (point) - (save-excursion - (haskell-back-to-zero-indent) - (point))))) - (if (and - (>= (car state) 0) - (not (or (nth 3 state) (nth 4 state)))) - ;;The parenthesis just inserted has a match - ;; and is not in a string or a comment - ;; so blink on its match - (save-excursion - (goto-char (nth 2 state)) - (sit-for 1))))) - - - -;;; This function indents the line expecting the line to be a -;;; continued function application. - -;;; foo a = bar a -;;; b {haskell-further-indent applied to this line -;;; indents the line as shown} - -;;; The line would look like this if only tab had been applied: -;;; foo a = bar a -;;; b - -(defun haskell-further-indent () - "Indents the line more than the ordinary indentation in order to -extend function arguments over multiple lines." - (interactive) - (let (indent - (new-point (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-keyword) - (point))))) - (save-excursion - ;;This may be a continuation of a function - ;; application so go back to the last '=' - ;; and set indent as designated by the style chosen - (goto-char new-point) - (skip-chars-forward "= \t") - (setq indent (haskell-list-align (haskell-eol)))) - ;;The argument to haskell-list-align is not important here. - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-to indent)) - (if (< (current-column) indent) - (move-to-column indent)))) - - -;;; This function indents the current line to the first previous -;;; indentation value which is less than the current indentation. - -(defun haskell-lesser-indent () - "Indents the current line to the first previous indentation -value which is less than the current indentation." - (interactive) - (let ((original-indent - (current-indentation)) - (indent (haskell-context-indent)) - (done nil)) - (save-excursion - (while (not done) - (while (and (not (bobp)) - (not (zerop (current-indentation))) - (>= indent original-indent)) - (haskell-backward-to-noncomment) - (setq indent (current-indentation))) - ;;bobp or indent < original-indent - (if (>= indent original-indent) - ;;indent is still greater than or equal to original indent - (progn - (setq indent 0) - (setq done t)) - ;;Otherwise, indent is less than orignal indent. - (forward-line 1) - (setq indent (haskell-context-indent)) - (if (< indent original-indent) - ;;The new indent is an improvement - (setq done t) - ;;Otherwise, indent is still >= original - ;; so go back to the line and keep typing. - (forward-line -1))))) - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-to indent)) - (if (< (current-column) indent) - (move-to-column indent)))) - - - -;;; Here are the functions which change the local variables -;;; to facilitate tailorability. - -(defun default-mode () - "Calls the function haskell-mode." - (interactive) - (haskell-mode) - (message haskell-indent-style)) - -(defun wadler-mode () - "Sets defaults according to Dr. Philip L. Wadler's preferences. - - Aligns `where' clauses with the corresponding equality. - - Aligns `else' keyword with the corresponding `then' - - haskell-list-offset 2 - - haskell-indent-offset 8 - - haskell-if-indent 2 - - haskell-comment-column 0 - - haskell-case-offset 2 - - haskell-let-offset 5." - ;;Preferences: - ;;'haskell-align-where-with-eq non-nil - ;;'haskell-list-offset 2 - (interactive) - (haskell-mode) - (or haskell-align-where-with-eq - (progn - (setq haskell-align-where-with-eq t) - (setq haskell-std-indent-where nil))) - (setq haskell-align-else-with-then t) - (setq haskell-list-offset 2) - (setq haskell-indent-offset 8) - (setq haskell-if-offset 2) - (setq haskell-case-offset 2) - (setq haskell-let-offset 5) - (setq haskell-comment-column 0) - (setq haskell-indent-style "Wadler") - (message haskell-indent-style)) - - -(defun report-mode () - "Sets defaults according to the style of the Haskell Report. - - Aligns `where' clauses after the corresponding equality. - - Aligns `else' with `then'. - - haskell-then-offset = 3 - - haskell-where-offset = 0. - - haskell-case-offset = 5." - ;;Preferences: - ;; haskell-align-where-after-eq non-nil - ;; haskell-then-offset 3 - ;; haskell-where-offset 0 - ;; haskell-case-offset 5 - (interactive) - (haskell-mode) - (haskell-align-where-after-eq) - (or haskell-align-else-with-then - (haskell-align-else-with-then)) - (setq haskell-then-offset 3) - (setq haskell-where-offset 0) - (setq haskell-case-offset 5) - (setq haskell-indent-style "Report") - (message haskell-indent-style)) - - -(defun haskell-align-where-with-eq () - "Sets indentation so that a 'where' clause lines up underneath -its corresponding equals sign." - (interactive) - (or haskell-align-where-with-eq - (progn - (setq haskell-align-where-after-eq nil) - (setq haskell-std-indent-where nil) - (setq haskell-align-where-with-eq t) - haskell-align-where-with-eq))) - - - -(defun haskell-align-where-after-eq () - "Sets indentation so that a 'where' clause lines up underneath -the first nonspace character after its corresponding equals sign." - (interactive) - (or haskell-align-where-after-eq - (progn - (setq haskell-align-where-with-eq nil) - (setq haskell-std-indent-where nil) - (setq haskell-align-where-after-eq t) - haskell-align-where-after-eq))) - - -(defun haskell-std-indent-where () - "Sets indentation so that a `where' clause lines up underneath -its corresponding equals sign." - (interactive) - (or haskell-std-indent-where - (progn - (setq haskell-align-where-after-eq nil) - (setq haskell-align-where-with-eq nil) - (setq haskell-std-indent-where t) - haskell-std-indent-where))) - - -(defun haskell-align-else-with-then () - "Sets indentation so that an `else' lines up underneath -it's corresponding `then'." - (interactive) - (setq haskell-align-else-with-then - (not haskell-align-else-with-then)) - (setq haskell-nest-ifs nil)) - -(defun haskell-nest-ifs () - "Sets indentation so that an `if' is lined up -under an `if' in an `else ." - (interactive) - (setq haskell-nest-ifs - (not haskell-nest-ifs)) - (setq haskell-align-else-with-then nil)) - - -(defun haskell-always-fixup-comment-space () - "Non-nil means always position one space after a line comment `--', -when reindenting or inserting a comment, -whether or not one space exists." - (setq haskell-always-fixup-comment-space - (not haskell-always-fixup-comment-space)) - haskell-always-fixup-comment-space) - -(defun haskell-indent-style () - "Echos the chosen indentation style in the mini-buffer." - (interactive) - (message haskell-indent-style)) - -(defun set-haskell-let-offset (offset) - "Changes the value of haskell-let-offset, the variable which -determines extra indentation after a `let' and `in'." - (interactive "nSet haskell-let-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-let-offset offset))) - -(defun set-haskell-if-offset (offset) - "Changes the value of haskell-let-offset, the variable which -determines extra indentation after an `if', `then' and `else'." - (interactive "nSet haskell-if-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-if-offset offset))) - -(defun set-haskell-case-offset (offset) - "Changes the value of haskell-case-offset, the variable which -determines extra indentation after a `case' and `of'." - (interactive "nSet haskell-case-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-case-offset offset))) - - -(defun set-haskell-where-offset (offset) - "Changes the value of haskell-where-offset, the variable which -determines extra indentation after a line of haskell code." - (interactive "nSet haskell-where-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-where-offset offset))) - - -(defun set-haskell-indent-offset (offset) - "Changes the value of haskell-indent-offset, the variable which -determines extra indentation after a line of haskell code." - (interactive "nSet haskell-indent-offset to: ") - (if (and (>= offset 1) (<= offset 10)) - (setq haskell-indent-offset offset))) - - -(defun set-haskell-list-offset (offset) - "Changes the value of haskell-list-offset, the variable which -determines extra indentation after a line of haskell code for a list." - (interactive "nSet haskell-list-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-list-offset offset))) - - -(defun set-haskell-comp-offset (offset) - "Changes the value of haskell-comp-offset, the variable which -determines extra indentation after a list comprehension." - (interactive "nSet haskell-comp-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-comp-offset offset))) - - -(defun set-haskell-then-offset (offset) - "Changes the value of haskell-then-offset, the variable which -determines extra indentation for a `then' keyword after an `if'." - (interactive "nSet haskell-then-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-then-offset offset))) - - -(defun set-haskell-comment-column (column) - "Changes the value of haskell-comment-column, the variable which -determines where to postition a line comment `--'." - (interactive "nSet haskell-comment-column to: ") - (if (and (>= column 0) (<= column 100)) - (setq haskell-comment-column column))) - -(defun set-haskell-concat-column (column) - "Changes the value of haskell-concat-column, the variable which -determines where to postition a concatenation operator `++'." - (interactive "nSet haskell-concat-column to: ") - (if (and (>= column 0) (<= column 100)) - (setq haskell-concat-column column))) - -(defun set-haskell-where-threshold (column) - "Changes the value of haskell-where-threshold, the variable which -determines when to override positioning a `where' under or after -its corresponding equality." - (interactive "nSet haskell-where-threshold to: ") - (if (and (>= column 0) (<= column 100)) - (setq haskell-where-threshold column))) - -(defun flag ())
\ No newline at end of file diff --git a/ghc/CONTRIB/haskell-modes/glasgow/original/manual.dvi b/ghc/CONTRIB/haskell-modes/glasgow/original/manual.dvi Binary files differdeleted file mode 100644 index 616b0fcb84..0000000000 --- a/ghc/CONTRIB/haskell-modes/glasgow/original/manual.dvi +++ /dev/null diff --git a/ghc/CONTRIB/haskell-modes/glasgow/original/report.dvi b/ghc/CONTRIB/haskell-modes/glasgow/original/report.dvi Binary files differdeleted file mode 100644 index 5f7aaebabf..0000000000 --- a/ghc/CONTRIB/haskell-modes/glasgow/original/report.dvi +++ /dev/null diff --git a/ghc/CONTRIB/haskell-modes/simonm/ghc/haskell.el b/ghc/CONTRIB/haskell-modes/simonm/ghc/haskell.el deleted file mode 100644 index 43461eb69f..0000000000 --- a/ghc/CONTRIB/haskell-modes/simonm/ghc/haskell.el +++ /dev/null @@ -1,185 +0,0 @@ -;;; Haskell mode for emacs (c) Simon Marlow 11/1/92 - -;;; To: partain@dcs.gla.ac.uk -;;; Subject: Haskell mode for emacs -;;; Date: Mon, 14 Dec 92 17:41:56 +0000 -;;; From: Simon Marlow <simonm@dcs.gla.ac.uk> -;;; -;;; ... What it buys you: very little actually, but the nice things are -;;; -;;; (i) Pressing line feed indents the next line according to the -;;; previous one, -;;; (ii) Pressing Meta-; gives you a comment on the current line, -;;; (iii) For literate scripts, pressing line feed gives you a bird -;;; track on the next line if there was one on the previous -;;; line, and does the indentation -;;; (iv) For literate scripts, pressing Meta-Tab toggles a bird track -;;; on or off at the beginning of the current line, -;;; (v) There's a function for toggling bird tracks on all lines in a -;;; region. -;;; (vi) Emacs says "Haskell" or "Literate Haskell" in the mode line :-) -;;; -;;; You'll have to make the necessary changes in .emacs to load in the -;;; library automatically (you probably know what to do). ... - -(defvar haskell-mode-map () - "Keymap used in Haskell mode.") - -(defvar haskell-literate-mode-map () - "Keymap used in Haskell literate script mode.") - -(defvar haskell-mode-syntax-table () - "Syntax table for haskell mode.") - -(if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)) - -(if haskell-literate-mode-map - () - (setq haskell-literate-mode-map (make-sparse-keymap)) - (define-key haskell-literate-mode-map "\C-j" 'haskell-literate-newline-and-indent) - (define-key haskell-literate-mode-map "\M-\C-i" 'haskell-literate-toggle-bird-track-line)) - -(if haskell-mode-syntax-table - () - (let ((i 0)) - (setq haskell-mode-syntax-table (make-syntax-table)) - (while (< i ?0) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?9)) - (modify-syntax-entry i "_" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?A) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?Z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?a) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i 128) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (modify-syntax-entry ? " " haskell-mode-syntax-table) - (modify-syntax-entry ?\t " " haskell-mode-syntax-table) - (modify-syntax-entry ?\n ">" haskell-mode-syntax-table) - (modify-syntax-entry ?\f ">" haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) - (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) - (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) - (modify-syntax-entry ?- "_ 123" haskell-mode-syntax-table) - )) - -(defun haskell-vars () - (kill-all-local-variables) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--[^a-zA-Z0-9]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'haskell-comment-indent)) - -(defun haskell-mode () - "Major mode for editing Haskell programs. -Blank lines separate paragraphs, Comments start with '--'. -Use Linefeed to do a newline and indent to the level of the previous line. -Tab simply inserts a TAB character. -Entry to this mode calls the value of haskell-mode-hook if non-nil." - (interactive) - (haskell-vars) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (use-local-map haskell-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - -(defun haskell-literate-mode () - "Major mode for editing haskell programs in literate script form. -Linefeed produces a newline, indented maybe with a bird track on it. -M-TAB toggles the state of the bird track on the current-line. -Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook." - (interactive) - (haskell-vars) - (setq major-mode 'haskell-literate-mode) - (setq mode-name "Literate Haskell") - (use-local-map haskell-literate-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook) - (run-hooks 'haskell-literate-mode-hook)) - -;; Find the indentation level for a comment.. -(defun haskell-comment-indent () - (skip-chars-backward " \t") - ;; if the line is blank, put the comment at the beginning, - ;; else at comment-column - (if (bolp) 0 (max (1+ (current-column)) comment-column))) - -;; Newline, and indent according to the previous line's indentation. -;; Don't forget to use 'indent-tabs-mode' if you require tabs to be used -;; for indentation. -(defun haskell-newline-and-indent () - (interactive) - (newline) - (let ((c 0)) - (save-excursion - (forward-line -1) - (back-to-indentation) - (setq c (if (eolp) 0 (current-column)))) - (indent-to c))) ;ident new line to this level - -;;; Functions for literate scripts - -;; Newline and maybe add a bird track, indent -(defun haskell-literate-newline-and-indent () - (interactive) - (newline) - (let ((bird-track nil) (indent-column 0)) - (save-excursion - (forward-line -1) - (if (= (following-char) ?>) (setq bird-track t)) - (skip-chars-forward "^ \t") - (skip-chars-forward " \t") - (setq indent-column (if (eolp) 0 (current-column)))) - (if bird-track (insert-char ?> 1)) - (indent-to indent-column))) - -;; Toggle bird-track ][ -(defun haskell-literate-toggle-bird-track-line () - (interactive) - (save-excursion - (beginning-of-line) - (if (= (following-char) ? ) - (progn (delete-char 1) (insert-char ?> 1)) - (if (= (following-char) ?>) - (progn (delete-char 1) (insert-char ? 1)) - (progn (insert-char ?> 1) (insert-char ? 1)))))) - -(defun haskell-literate-toggle-bird-track-region (start end) - (interactive "r") - (save-excursion - (goto-char start) - (while (<= (point) end) - (beginning-of-line) - (haskell-literate-toggle-bird-track-line) - (forward-line 1)))) - diff --git a/ghc/CONTRIB/haskell-modes/simonm/real/haskell.el b/ghc/CONTRIB/haskell-modes/simonm/real/haskell.el deleted file mode 100644 index 6adc7441ed..0000000000 --- a/ghc/CONTRIB/haskell-modes/simonm/real/haskell.el +++ /dev/null @@ -1,202 +0,0 @@ -;;; Haskell mode for emacs (c) Simon Marlow 11/1/92 - -(defvar haskell-mode-map () - "Keymap used in Haskell mode.") - -(defvar haskell-literate-mode-map () - "Keymap used in Haskell literate script mode.") - -(defvar haskell-mode-syntax-table () - "Syntax table for haskell mode.") - -(if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)) - -(if haskell-literate-mode-map - () - (setq haskell-literate-mode-map (make-sparse-keymap)) - (define-key haskell-literate-mode-map "\C-j" - 'haskell-literate-newline-and-indent) - (define-key haskell-literate-mode-map "\M-\C-i" - 'haskell-literate-toggle-bird-track-line) - (define-key haskell-literate-mode-map "\M-m" - 'haskell-literate-back-to-indentation)) - - -(if haskell-mode-syntax-table - () - (let ((i 0)) - (setq haskell-mode-syntax-table (make-syntax-table)) -; (while (< i ?0) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i (1+ ?9)) -; (modify-syntax-entry i "_" haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i ?A) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i (1+ ?Z)) -; (modify-syntax-entry i "w" haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i ?a) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i (1+ ?z)) -; (modify-syntax-entry i "w" haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i 128) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) - (modify-syntax-entry ? " " haskell-mode-syntax-table) - (modify-syntax-entry ?\t " " haskell-mode-syntax-table) - (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) - (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) - (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) - (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) - (modify-syntax-entry ?- ". 12b" haskell-mode-syntax-table) - )) - -(defun haskell-vars () - (kill-all-local-variables) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--[^a-zA-Z0-9]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'haskell-comment-indent) - ) - -(defun haskell-mode () - "Major mode for editing Haskell programs. -Blank lines separate paragraphs, Comments start with '--'. -Use Linefeed to do a newline and indent to the level of the previous line. -Tab simply inserts a TAB character. -Entry to this mode calls the value of haskell-mode-hook if non-nil." - (interactive) - (haskell-vars) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (use-local-map haskell-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - -(defun haskell-literate-mode () - "Major mode for editing haskell programs in literate script form. -Linefeed produces a newline, indented maybe with a bird track on it. -M-TAB toggles the state of the bird track on the current-line. -Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook." - (interactive) - (haskell-vars) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords haskell-literate-font-lock-keywords) - (setq major-mode 'haskell-literate-mode) - (setq mode-name "Literate Haskell") - (use-local-map haskell-literate-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook) - (run-hooks 'haskell-literate-mode-hook)) - -;; Find the indentation level for a comment.. -(defun haskell-comment-indent () - (skip-chars-backward " \t") - ;; if the line is blank, put the comment at the beginning, - ;; else at comment-column - (if (bolp) 0 (max (1+ (current-column)) comment-column))) - -;; Newline, and indent according to the previous line's indentation. -;; Don't forget to use 'indent-tabs-mode' if you require tabs to be used -;; for indentation. -(defun haskell-newline-and-indent () - (interactive) - (newline) - (let ((c 0)) - (save-excursion - (forward-line -1) - (back-to-indentation) - (setq c (if (eolp) 0 (current-column)))) - (indent-to c))) ;ident new line to this level - -;;; Functions for literate scripts - -;; Newline and maybe add a bird track, indent -(defun haskell-literate-newline-and-indent () - (interactive) - (newline) - (let ((bird-track nil) (indent-column 0)) - (save-excursion - (forward-line -1) - (if (= (following-char) ?>) (setq bird-track t)) - (skip-chars-forward "^ \t") - (skip-chars-forward " \t") - (setq indent-column (if (eolp) 0 (current-column)))) - (if bird-track (insert-char ?> 1)) - (indent-to indent-column))) - -;; Toggle bird-track ][ -(defun haskell-literate-toggle-bird-track-line () - (interactive) - (save-excursion - (beginning-of-line) - (if (= (following-char) ? ) - (progn (delete-char 1) (insert-char ?> 1)) - (if (= (following-char) ?>) - (progn (delete-char 1) (insert-char ? 1)) - (progn (insert-char ?> 1) (insert-char ? 1)))))) - -(defun haskell-literate-toggle-bird-track-region (start end) - (interactive "r") - (save-excursion - (goto-char start) - (while (<= (point) end) - (beginning-of-line) - (haskell-literate-toggle-bird-track-line) - (forward-line 1)))) - -(defun haskell-literate-back-to-indentation () - (interactive) - (beginning-of-line) - (if (= (following-char) ?>) - (forward-char 1)) - (skip-chars-forward " \t")) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; keywords for jwz's font-look-mode (lemacs 19) -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-literate-font-lock-keywords () - "Font definitions for Literate Haskell files.") - -(setq haskell-literate-font-lock-keywords - (list - '("^[^>\n].*$" . font-lock-comment-face) - (concat "\\b\\(" - (mapconcat 'identity - '("case" "class" "data" "default" "deriving" "else" - "hiding" "if" "import" "in" "infix" "infixl" - "infixr" "instance" "interface" "let" "module" - "of" "renaming" "then" "to" "type" "where") - "\\|") - "\\)\\b") -; '("(\\|)\\|\\[\\|\\]\\|,\\|[\\\\!$#^%&*@~?=-+<>.:]+" . font-lock-function-name-face) - )) - diff --git a/ghc/CONTRIB/haskell-modes/yale/chak/haskell.el b/ghc/CONTRIB/haskell-modes/yale/chak/haskell.el deleted file mode 100644 index 4470553ce9..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/chak/haskell.el +++ /dev/null @@ -1,1866 +0,0 @@ -;;; ================================================================== -;;; File: haskell.el ;;; -;;; ;;; -;;; Author: A. Satish Pai ;;; -;;; Maria M. Gutierrez ;;; -;;; Dan Rabin (Jul-1991) ;;; -;;; ================================================================== -;;; Time-stamp: <Sat Oct 7 1995 17:48:39 Stardate: [-31]6403.50 hwloidl> -;;; ================================================================== -;;; -;;; extended by Manuel M.T. Chakravarty with rudimentary editing features -;;; (including better syntax table) and support for the font-lock-mode; -;;; changes are marked with !chak! -;;; -;;; using this mode on a 19.x Emacs running under a window system automagically -;;; applies the font-lock-mode; this feature can be switched off by setting -;;; `haskell-auto-font-lock' to `nil' - -;;; Description: Haskell mode for GNU Emacs. - -;;; Related files: comint.el - -;;; Contents: - -;;; Update Log - -;;; Known bugs / problems -;;; - the haskell editing mode (indentation, etc) is still missing. -;;; - the handling for errors from haskell needs to be rethought. -;;; - general cleanup of code. - - -;;; Errors generated - -;;; ================================================================== -;;; Haskell mode for editing files, and an Inferior Haskell mode to -;;; run a Haskell process. This file contains stuff snarfed and -;;; modified from tea.el, scheme.el, etc. This file may be freely -;;; modified; however, if you have any bug-corrections or useful -;;; improvements, I'd appreciate it if you sent me the mods so that -;;; I can merge them into the version I maintain. -;;; -;;; The inferior Haskell mode requires comint.el. -;;; -;;; You might want to add this to your .emacs to go automagically -;;; into Haskell mode while finding .hs files. -;;; -;;; (setq auto-mode-alist -;;; (cons '("\\.hs$" . haskell-mode) -;;; auto-mode-alist)_) -;;; -;;; To use this file, set up your .emacs to autoload this file for -;;; haskell-mode. For example: -;;; -;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; [Note: The path name given above is Yale specific!! Modify as -;;; required.] -;;; ================================================================ - -;;; Announce your existence to the world at large. - -(provide 'haskell) - - -;;; Load these other files. - -(require 'comint) ; Olin Shivers' comint mode is the substratum - -;;; !chak! -;;; -(if (and window-system (string-match "19." emacs-version)) - (require 'font-lock)) - - - -;;; ================================================================ -;;; Declare a bunch of variables. -;;; ================================================================ - - -;;; User settable (via M-x set-variable and M-x edit-options) - -(defvar haskell-program-name (getenv "HASKELLPROG") - "*Program invoked by the haskell command.") - -(defvar haskell-auto-create-process t - "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.") - -(defvar haskell-auto-switch-input t - "*If not nil, jump to *haskell* buffer automatically on input request.") - -(defvar haskell-ask-before-saving t - "*If not nil, ask before saving random haskell-mode buffers.") - -(defvar haskell-initial-printers '("interactive") - "*Printers to set when starting a new Haskell process.") - - -;;; Pad/buffer Initialization variables - -(defvar *haskell-buffer* "*haskell*" - "Name of the haskell process buffer") - -(defvar haskell-main-pad "\*Main-pad\*" - "Scratch pad associated with module Main") - -(defvar haskell-main-module "Main") - - -(defvar *last-loaded* nil) -(defvar *last-module* haskell-main-module) -(defvar *last-pad* haskell-main-pad) - - -;;; These are used for haskell-tutorial mode. - -(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs") -(defvar *ht-temp-buffer* nil) -(defvar *ht-file-buffer* "Haskell-Tutorial-Master") - -;;; !chak! variables for font-lock-mode support -;;; - -(defvar haskell-auto-font-lock t - "Use font-lock-mode by default.") - -(defvar haskell-font-lock-keywords - (list - "\\bcase\\b" "\\bclass\\b" "\\bdata\\b" "\\bdefault\\b" "\\bderiving\\b" - "\\belse\\b" "\\bhiding\\b" "\\bif\\b" "\\bimport\\b" "\\bin\\b" - "\\binfix\\b" "\\binfixl\\b" "\\binfixr\\b" "\\binstance\\b" - "\\binterface\\b" "\\blet\\b" "\\bmodule\\b" "\\bof\\b" "\\brenaming\\b" - "\\bthen\\b" "\\bto\\b" "\\btype\\b" "\\bwhere\\b" - ;'("\\S_\\(\\.\\.\\|::\\|=>\\|=\\|@\\||\\|~\\|-\\|<-\\|->\\)\\S_" . 1) - '("\\bdata\\b\\s *\\(\\w+\\)\\(\\w\\|\\s \\)*=[^>]" 1 font-lock-type-face) - '("\\bdata\\b\\(\\s \\|(\\|)\\|\\w\\)*=>\\s *\n?\\s *\\(\\w+\\)" 2 - font-lock-type-face) - '("\\btype\\b\\s *\\(\\w+\\)" 1 font-lock-type-face) - '("\\(\\w+\\)\\s *::\\(\\s \\|$\\)" 1 font-lock-function-name-face) - '("(\\(\\s_+\\))\\s *::\\(\\s \\|$\\)" 1 font-lock-function-name-face) -; '("\\($\\|[^\\\\]\\)\\('[^\\\\]'\\)" 2 font-lock-string-face t) - '("\\('\\([^\\\\]\\|\\\\'\\)'\\)" 1 font-lock-string-face t) - ) - "Additional expressions to highlight in Haskell mode.") - - - -;;; ================================================================ -;;; Haskell editing mode stuff -;;; ================================================================ - -;;; Leave this place alone... -;;; The definitions below have been pared down to the bare -;;; minimum; they will be restored later. -;;; -;;; -Satish 2/5. - -;;; Keymap for Haskell mode -(defvar haskell-mode-map (make-sparse-keymap) - "Keymap used for haskell-mode") - -(defun haskell-establish-key-bindings (keymap) - (define-key keymap "\C-ce" 'haskell-eval) - (define-key keymap "\C-cr" 'haskell-run) - (define-key keymap "\C-ct" 'haskell-report-type) - (define-key keymap "\C-cm" 'haskell-run-main) - (define-key keymap "\C-c\C-r" 'haskell-run-file) - (define-key keymap "\C-cp" 'haskell-get-pad) - (define-key keymap "\C-c\C-o" 'haskell-optimizers) - (define-key keymap "\C-c\C-p" 'haskell-printers) - (define-key keymap "\C-cc" 'haskell-compile) - (define-key keymap "\C-cl" 'haskell-load) - (define-key keymap "\C-ch" 'haskell-switch) - (define-key keymap "\C-c\C-k" 'haskell-kill) - (define-key keymap "\C-c:" 'haskell-command) - (define-key keymap "\C-cq" 'haskell-exit) - (define-key keymap "\C-ci" 'haskell-interrupt) - (define-key keymap "\C-cu" 'haskell-edit-unit)) - - -(haskell-establish-key-bindings haskell-mode-map) - - -(defvar haskell-mode-syntax-table nil - "Syntax table used for haskell-mode") - -;; !chak! taken from lisp-mode -;; -(defvar haskell-mode-abbrev-table nil - "Abbrev table used for the haskell-mode") - -;; !chak! took syntax table from haskell mode distributed with GHC and modified -;; it; we treat numbers as parts of words and operators as elements of -;; the syntactic class `_' -;; -(if haskell-mode-syntax-table - () - (let ((i 0)) - (setq haskell-mode-syntax-table (make-syntax-table)) - (while (< i ?0) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?9)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?A) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?Z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?a) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i 128) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (modify-syntax-entry ? " " haskell-mode-syntax-table) - (modify-syntax-entry ?\t " " haskell-mode-syntax-table) - (modify-syntax-entry ?\n ">" haskell-mode-syntax-table) - (modify-syntax-entry ?\f ">" haskell-mode-syntax-table) - (modify-syntax-entry ?! "_" haskell-mode-syntax-table) - (modify-syntax-entry ?# "_" haskell-mode-syntax-table) - (modify-syntax-entry ?$ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?% "_" haskell-mode-syntax-table) - (modify-syntax-entry ?& "_" haskell-mode-syntax-table) - (modify-syntax-entry ?* "_" haskell-mode-syntax-table) - (modify-syntax-entry ?+ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?. "_" haskell-mode-syntax-table) - (modify-syntax-entry ?/ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?< "_" haskell-mode-syntax-table) - (modify-syntax-entry ?= "_" haskell-mode-syntax-table) - (modify-syntax-entry ?> "_" haskell-mode-syntax-table) - (modify-syntax-entry ?? "_" haskell-mode-syntax-table) - (modify-syntax-entry ?@ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?^ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?| "_" haskell-mode-syntax-table) - (modify-syntax-entry ?~ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) - (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) - (modify-syntax-entry ?- "_ 123" haskell-mode-syntax-table) - )) - -;; !chak! taken from lisp-mode -;; -(define-abbrev-table 'haskell-mode-abbrev-table ()) - -;; !chak! adapted from lisp-mode -;; -(defun haskell-mode-variables (haskell-syntax) - (cond (haskell-syntax - (set-syntax-table haskell-mode-syntax-table))) - (setq local-abbrev-table haskell-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'haskell-indent-line) -; (make-local-variable 'indent-region-function) -; (setq indent-region-function 'haskell-indent-region) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) -; (make-local-variable 'outline-regexp) -; (setq outline-regexp ";;; \\|(....") - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "-- *") - (make-local-variable 'comment-column) - (setq comment-column 40) -; (make-local-variable 'comment-indent-function) -; (setq comment-indent-function 'haskell-comment-indent) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords haskell-font-lock-keywords) - ) - -;; !chak! -;; -(defun haskell-indent-line () - "Simple indentation function using `indent-relative'." - (interactive) - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-relative) - ) - ) - -;;; Command for invoking the Haskell mode -(defun haskell-mode nil - "Major mode for editing Haskell code to run in Emacs -The following commands are available: -\\{haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks that are the value of variable -haskell-mode-hook. - -Windows: - -There are 3 types of windows associated with Haskell mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued . - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file buffer, then the cursor tells which module is the current - module and the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main in the current module. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. -" - (interactive) - (kill-all-local-variables) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-relative-maybe) - ;(setq local-abbrev-table haskell-mode-abbrev-table) - (set-syntax-table haskell-mode-syntax-table) - ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list?? - (haskell-mode-variables t) ; !chak! - (cond (haskell-auto-font-lock ; !chak! - (font-lock-mode 1) ; !chak! - )) ; !chak! - (run-hooks 'haskell-mode-hook)) - - - -;;;================================================================ -;;; Inferior Haskell stuff -;;;================================================================ - - -(defvar inferior-haskell-mode-map (copy-keymap comint-mode-map)) - -(haskell-establish-key-bindings inferior-haskell-mode-map) -(define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input) - -(defvar haskell-source-modes '(haskell-mode) - "*Used to determine if a buffer contains Haskell source code. -If it's loaded into a buffer that is in one of these major modes, -it's considered a Haskell source file.") - -(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" - "Regular expression capturing the Haskell system prompt.") - -(defvar haskell-prompt-ring () - "Keeps track of input to haskell process from the minibuffer") - -(defun inferior-haskell-mode-variables () - nil) - - -;;; INFERIOR-HASKELL-MODE (adapted from comint.el) - -(defun inferior-haskell-mode () - "Major mode for interacting with an inferior Haskell process. - -The following commands are available: -\\{inferior-haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks on comint-mode-hook and -inferior-haskell-mode-hook (in that order). - -You can send text to the inferior Haskell process from other buffers containing -Haskell source. - - -Windows: - -There are 3 types of windows in the inferior-haskell-mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued. - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file, then the cursor tells which module is the current module and - the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. - -The usual comint functions are also available. In particular, the -following are all available: - -comint-bol: Beginning of line, but skip prompt. Bound to C-a by default. -comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in - which case send EOF to process. Bound to C-d by default. - -Note however, that the default keymap bindings provided shadow some of -the default comint mode bindings, so that you may want to bind them -to your choice of keys. - -Comint mode's dynamic completion of filenames in the buffer is available. -(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.) - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - - (interactive) - (comint-mode) - (setq comint-prompt-regexp haskell-prompt-pattern) - ;; Customise in inferior-haskell-mode-hook - (inferior-haskell-mode-variables) - (setq major-mode 'inferior-haskell-mode) - (setq mode-name "Inferior Haskell") - (setq mode-line-process '(": %s : busy")) - (use-local-map inferior-haskell-mode-map) - (setq comint-input-filter 'haskell-input-filter) - (setq comint-input-sentinel 'ignore) - (setq comint-get-old-input 'haskell-get-old-input) - (run-hooks 'inferior-haskell-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq haskell-prompt-ring (make-ring comint-input-ring-size))) - - -(defun haskell-input-filter (str) - "Don't save whitespace." - (not (string-match "\\s *" str))) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; This keeps track of the status of the haskell process. -;;; Values are: -;;; busy -- The process is busy. -;;; ready -- The process is ready for a command. -;;; input -- The process is waiting for input. -;;; debug -- The process is in the debugger. - -(defvar *haskell-status* 'busy - "Status of the haskell process") - -(defun set-haskell-status (value) - (setq *haskell-status* value) - (haskell-update-mode-line)) - -(defun get-haskell-status () - *haskell-status*) - -(defun haskell-update-mode-line () - (save-excursion - (set-buffer *haskell-buffer*) - (cond ((eq *haskell-status* 'ready) - (setq mode-line-process '(": %s: ready"))) - ((eq *haskell-status* 'input) - (setq mode-line-process '(": %s: input"))) - ((eq *haskell-status* 'busy) - (setq mode-line-process '(": %s: busy"))) - ((eq *haskell-status* 'debug) - (setq mode-line-process '(": %s: debug"))) - (t - (haskell-mode-error "Confused about status of haskell process!"))) - ;; Yes, this is the officially sanctioned technique for forcing - ;; a redisplay of the mode line. - (set-buffer-modified-p (buffer-modified-p)))) - - -(defun haskell-send-to-process (string) - (process-send-string "haskell" string) - (process-send-string "haskell" "\n")) - - - -;;; ================================================================== -;;; Handle input in haskell process buffer; history commands. -;;; ================================================================== - -(defun haskell-get-old-input () - "Get old input text from Haskell process buffer." - (save-excursion - (if (re-search-forward haskell-prompt-pattern (point-max) 'move) - (goto-char (match-beginning 0))) - (cond ((re-search-backward haskell-prompt-pattern (point-min) t) - (comint-skip-prompt) - (let ((temp (point))) - (end-of-line) - (buffer-substring temp (point))))))) - - -(defun haskell-send-input () - "Send input to Haskell while in the process buffer" - (interactive) - (if (eq (get-haskell-status) 'debug) - (comint-send-input) - (haskell-send-input-aux))) - -(defun haskell-send-input-aux () - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) - (haskell-mode-error "Current buffer has no process!") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (buffer-substring pmark (point)) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) - (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)) - (haskell-send-to-process input))))) - - - -;;; ================================================================== -;;; Minibuffer input stuff -;;; ================================================================== - -;;; Haskell input history retrieval commands (taken from comint.el) -;;; M-p -- previous input M-n -- next input - -(defvar haskell-minibuffer-local-map nil - "Local map for minibuffer when in Haskell") - -(if haskell-minibuffer-local-map - nil - (progn - (setq haskell-minibuffer-local-map - (copy-keymap minibuffer-local-map)) - ;; Haskell commands - (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input) - (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input) - )) - -(defun haskell-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length haskell-prompt-ring))) - (cond ((<= len 0) - (message "Empty input ring.") - (ding)) - (t - (cond ((eq last-command 'haskell-previous-input) - (delete-region (mark) (point)) - (set-mark (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (insert (ring-ref haskell-prompt-ring input-ring-index)) - (setq this-command 'haskell-previous-input)) - ))) - -(defun haskell-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (haskell-previous-input (- arg))) - -(defvar haskell-last-input-match "" - "Last string searched for by Haskell input history search, for defaulting. -Buffer local variable.") - -(defun haskell-previous-input-matching (str) - "Searches backwards through input history for substring match" - (interactive (let ((s (read-from-minibuffer - (format "Command substring (default %s): " - haskell-last-input-match)))) - (list (if (string= s "") haskell-last-input-match s)))) - (setq haskell-last-input-match str) ; update default - (let ((str (regexp-quote str)) - (len (ring-length haskell-prompt-ring)) - (n 0)) - (while (and (<= n len) - (not (string-match str (ring-ref haskell-prompt-ring n)))) - (setq n (+ n 1))) - (cond ((<= n len) (haskell-previous-input (+ n 1))) - (t (haskell-mode-error "Not found."))))) - - -;;; Actually read an expression from the minibuffer using the new keymap. - -(defun haskell-get-expression (prompt) - (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map))) - (ring-insert haskell-prompt-ring exp) - exp)) - - - -;;; ================================================================== -;;; Handle output from Haskell process -;;; ================================================================== - -;;; The haskell process produces output with embedded control codes. -;;; These control codes are used to keep track of what kind of input -;;; the haskell process is expecting. Ordinary output is just displayed. -;;; -;;; This is kind of complicated because control sequences can be broken -;;; across multiple batches of text received from the haskell process. -;;; If the string ends in the middle of a control sequence, save it up -;;; for the next call. - -(defvar *haskell-saved-output* nil) - -;;; On the Next, there is some kind of race condition that causes stuff -;;; sent to the Haskell subprocess before it has really started to be lost. -;;; The point of this variable is to force the Emacs side to wait until -;;; Haskell has started and printed out its banner before sending it -;;; anything. See start-haskell below. - -(defvar *haskell-process-alive* nil) - -(defun haskell-output-filter (process str) - "Filter for output from Yale Haskell command interface" - ;; *** debug - ;;(let ((buffer (get-buffer-create "haskell-output"))) - ;; (save-excursion - ;; (set-buffer buffer) - ;; (insert str))) - (setq *haskell-process-alive* t) - (let ((next 0) - (start 0) - (data (match-data))) - (unwind-protect - (progn - ;; If there was saved output from last time, glue it in front of the - ;; newly received input. - (if *haskell-saved-output* - (progn - (setq str (concat *haskell-saved-output* str)) - (setq *haskell-saved-output* nil))) - ;; Loop, looking for complete command sequences. - ;; Set next to point to the first one. - ;; start points to first character to be processed. - (while (setq next - (string-match *haskell-message-match-regexp* - str start)) - ;; Display any intervening ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next))) - ;; Now dispatch on the particular command sequence found. - ;; Handler functions are called with the string and start index - ;; as arguments, and should return the index of the "next" - ;; character. - (let ((end (match-end 0))) - (haskell-handle-message str next) - (setq start end))) - ;; Look to see whether the string ends with an incomplete - ;; command sequence. - ;; If so, save the tail of the string for next time. - (if (and (setq next - (string-match *haskell-message-prefix-regexp* str start)) - (eq (match-end 0) (length str))) - (setq *haskell-saved-output* (substring str next)) - (setq next (length str))) - ;; Display any leftover ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next)))) - (store-match-data data)))) - -(defvar *haskell-message-match-regexp* - "EMACS:.*\n") - -(defvar *haskell-message-prefix-regexp* - "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?") - -(defvar *haskell-message-dispatch* - '(("EMACS:debug\n" . haskell-got-debug) - ("EMACS:busy\n" . haskell-got-busy) - ("EMACS:input\n" . haskell-got-input) - ("EMACS:ready\n" . haskell-got-ready) - ("EMACS:printers .*\n" . haskell-got-printers) - ("EMACS:optimizers .*\n" . haskell-got-optimizers) - ("EMACS:message .*\n" . haskell-got-message) - ("EMACS:error\n" . haskell-got-error) - )) - -(defun haskell-handle-message (str idx) - (let ((list *haskell-message-dispatch*) - (fn nil)) - (while (and list (null fn)) - (if (eq (string-match (car (car list)) str idx) idx) - (setq fn (cdr (car list))) - (setq list (cdr list)))) - (if (null fn) - (haskell-mode-error "Garbled message from Haskell!") - (let ((end (match-end 0))) - (funcall fn str idx end) - end)))) - - -(defun haskell-message-data (string start end) - (let ((real-start (+ (string-match " " string start) 1)) - (real-end (- end 1))) - (substring string real-start real-end))) - -(defun haskell-got-debug (string start end) - (beep) - (message "In the debugger!") - (set-haskell-status 'debug)) - -(defun haskell-got-busy (string start end) - (set-haskell-status 'busy)) - -(defun haskell-got-input (string start end) - (if haskell-auto-switch-input - (progn - (haskell-switch) - (beep))) - (set-haskell-status 'input) - (message "Waiting for input...")) - -(defun haskell-got-ready (string start end) - (set-haskell-status 'ready)) - -(defun haskell-got-printers (string start end) - (haskell-printers-update (haskell-message-data string start end))) - -(defun haskell-got-optimizers (string start end) - (haskell-optimizers-update (haskell-message-data string start end))) - -(defun haskell-got-message (string start end) - (message "%s" (haskell-message-data string start end))) - -(defun haskell-got-error (string start end) -; [[!chak! I found that annoying]] (beep) - (message "Haskell error.")) - - -;;; Displays output at end of given buffer. -;;; This function only ensures that the output is visible, without -;;; selecting the buffer in which it is displayed. -;;; Note that just using display-buffer instead of all this rigamarole -;;; won't work; you need to temporarily select the window containing -;;; the *haskell-buffer*, or else the display won't be scrolled to show -;;; the new output. -;;; *** This should really position the window in the buffer so that -;;; *** the point is on the last line of the window. - -(defun haskell-display-output (str) - (let ((window (selected-window))) - (unwind-protect - (progn - (pop-to-buffer *haskell-buffer*) - (haskell-display-output-aux str)) - (select-window window)))) - -(defun haskell-display-output-aux (str) - (haskell-move-marker) - (insert str) - (haskell-move-marker)) - - - -;;; ================================================================== -;;; Interactive commands -;;; ================================================================== - - -;;; HASKELL -;;; ------- -;;; -;;; This is the function that fires up the inferior haskell process. - -(defun haskell () - "Run an inferior Haskell process with input and output via buffer *haskell*. -Takes the program name from the variable haskell-program-name. -Runs the hooks from inferior-haskell-mode-hook -(after the comint-mode-hook is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive) - (if (not (haskell-process-exists-p)) - (start-haskell))) - -(defun start-haskell () - (message "Starting haskell subprocess...") - ;; Kill old haskell process. Normally this routine is only called - ;; after checking haskell-process-exists-p, but things can get - ;; screwed up if you rename the *haskell* buffer while leaving the - ;; old process running. This forces it to get rid of the old process - ;; and start a new one. - (if (get-process "haskell") - (delete-process "haskell")) - (let ((haskell-buffer - (apply 'make-comint - "haskell" - (or haskell-program-name - (haskell-mode-error "Haskell-program-name undefined!")) - nil - nil))) - (save-excursion - (set-buffer haskell-buffer) - (inferior-haskell-mode)) - (haskell-session-init) - ;; Wait for process to get started before sending it anything - ;; to avoid race condition on NeXT. - (setq *haskell-process-alive* nil) - (while (not *haskell-process-alive*) - (sleep-for 1)) - (haskell-send-to-process ":(use-emacs-interface)") - (haskell-printers-set haskell-initial-printers nil) - (display-buffer haskell-buffer)) - (message "Starting haskell subprocess... Done.")) - - -(defun haskell-process-exists-p () - (let ((haskell-buffer (get-buffer *haskell-buffer*))) - (and haskell-buffer (comint-check-proc haskell-buffer)))) - - - -;;; Initialize things on the emacs side, and tell haskell that it's -;;; talking to emacs. - -(defun haskell-session-init () - (set-haskell-status 'busy) - (setq *last-loaded* nil) - (setq *last-module* haskell-main-module) - (setq *last-pad* haskell-main-pad) - (setq *haskell-saved-output* nil) - (haskell-create-main-pad) - (set-process-filter (get-process "haskell") 'haskell-output-filter) - ) - - -(defun haskell-create-main-pad () - (let ((buffer (get-buffer-create haskell-main-pad))) - (save-excursion - (set-buffer buffer) - (haskell-mode)) - (haskell-record-pad-mapping - haskell-main-pad haskell-main-module nil) - buffer)) - - -;;; Called from evaluation and compilation commands to start up a Haskell -;;; process if none is already in progress. - -(defun haskell-maybe-create-process () - (cond ((haskell-process-exists-p) - t) - (haskell-auto-create-process - (start-haskell)) - (t - (haskell-mode-error "No Haskell process!")))) - - - -;;; HASKELL-GET-PAD -;;; ------------------------------------------------------------------ - -;;; This always puts the pad buffer in the "other" window. -;;; Having it wipe out the .hs file window is clearly the wrong -;;; behavior. - -(defun haskell-get-pad () - "Creates a new scratch pad for the current module. -Signals an error if the current buffer is not a .hs file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (do-get-pad fname (current-buffer)) - (haskell-mode-error "Not in a .hs buffer!")))) - - -(defun do-get-pad (fname buff) - (let* ((mname (or (haskell-get-modname buff) - (read-no-blanks-input "Scratch pad for module? " nil))) - (pname (haskell-lookup-pad mname fname)) - (pbuff nil)) - ;; Generate the base name of the pad buffer, then create the - ;; buffer. The actual name of the pad buffer may be something - ;; else because of name collisions. - (if (not pname) - (progn - (setq pname (format "*%s-pad*" mname)) - (setq pbuff (generate-new-buffer pname)) - (setq pname (buffer-name pbuff)) - (haskell-record-pad-mapping pname mname fname) - ) - (setq pbuff (get-buffer pname))) - ;; Make sure the pad buffer is in haskell mode. - (pop-to-buffer pbuff) - (haskell-mode))) - - - -;;; HASKELL-SWITCH -;;; ------------------------------------------------------------------ - -(defun haskell-switch () - "Switches to \*haskell\* buffer." - (interactive) - (haskell-maybe-create-process) - (pop-to-buffer *haskell-buffer*) - (push-mark) - (goto-char (point-max))) - - - -;;; HASKELL-KILL -;;; ------------------------------------------------------------------ - -(defun haskell-kill () - "Kill contents of *haskell* buffer. \\[haskell-kill]" - (interactive) - (save-excursion - (set-buffer *haskell-buffer*) - (beginning-of-buffer) - (let ((mark (point))) - (end-of-buffer) - (kill-region mark (point))))) - - - -;;; HASKELL-COMMAND -;;; ------------------------------------------------------------------ - -(defun haskell-command (str) - "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]" - (interactive "sHaskell command: ") - (haskell-send-to-process (format ":%s" str))) - - -;;; HASKELL-EVAL and HASKELL-RUN -;;; ------------------------------------------------------------------ - -(defun haskell-eval () - "Evaluate expression in current module. \\[haskell-eval]" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-eval")) - -(defun haskell-run () - "Run Haskell Dialogue in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ") - "emacs-run")) - -(defun haskell-run-main () - "Run Dialogue named main in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux "main" "emacs-run")) - -(defun haskell-report-type () - "Print the type of the expression." - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-report-type")) - -(defun haskell-eval-aux (exp fn) - (cond ((equal *haskell-buffer* (buffer-name)) - ;; In the *haskell* buffer. - (let* ((pname *last-pad*) - (mname *last-module*) - (fname *last-loaded*)) - (haskell-eval-aux-aux exp pname mname fname fn))) - ((buffer-file-name) - ;; In a .hs file. - (let* ((fname (buffer-file-name)) - (mname (haskell-get-modname (current-buffer))) - (pname (haskell-lookup-pad mname fname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - (t - ;; In a pad. - (let* ((pname (buffer-name (current-buffer))) - (mname (haskell-get-module-from-pad pname)) - (fname (haskell-get-file-from-pad pname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - )) - -(defun haskell-eval-aux-aux (exp pname mname fname fn) - (haskell-save-modified-source-files fname) - (haskell-send-to-process (format ":(%s" fn)) - (haskell-send-to-process - (prin1-to-string exp)) - (haskell-send-to-process - (prin1-to-string (or pname fname "interactive"))) - (haskell-send-to-process - (prin1-to-string - (if (and pname (get-buffer pname)) - (save-excursion - (set-buffer pname) - (buffer-string)) - ""))) - (haskell-send-to-process - (format "'|%s|" mname)) - (haskell-send-to-process - (if fname - (prin1-to-string (haskell-maybe-get-unit-file-name fname)) - "'#f")) - (haskell-send-to-process ")") - (setq *last-pad* pname) - (setq *last-module* mname) - (setq *last-loaded* fname)) - - - -;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE -;;; ------------------------------------------------------------------ - -(defun haskell-run-file () - "Runs Dialogue named main in current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-run-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-load () - "Load current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-load-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-compile () - "Compile current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-compile-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - - -(defun haskell-get-file-to-operate-on () - (cond ((equal *haskell-buffer* (buffer-name)) - ;; When called from the haskell process buffer, prompt for a file. - (call-interactively 'haskell-get-file/prompt)) - ((buffer-file-name) - ;; When called from a .hs file buffer, use the unit file - ;; associated with it, if there is one. - (haskell-maybe-get-unit-file-name (buffer-file-name))) - (t - ;; When called from a pad, use the file that the module the - ;; pad belongs to lives in. - (haskell-maybe-get-unit-file-name - (haskell-get-file-from-pad (buffer-name (current-buffer))))))) - -(defun haskell-get-file/prompt (filename) - (interactive "fHaskell file: ") - filename) - - - -;;; HASKELL-EXIT -;;; ------------------------------------------------------------------ - -(defun haskell-exit () - "Quit the haskell process." - (interactive) - (cond ((not (haskell-process-exists-p)) - (message "No process currently running.")) - ((y-or-n-p "Do you really want to quit Haskell? ") - (haskell-send-to-process ":quit") - ;; If we were running the tutorial, mark the temp buffer as unmodified - ;; so we don't get asked about saving it later. - (if (and *ht-temp-buffer* - (get-buffer *ht-temp-buffer*)) - (save-excursion - (set-buffer *ht-temp-buffer*) - (set-buffer-modified-p nil))) - ;; Try to remove the haskell output buffer from the screen. - (bury-buffer *haskell-buffer*) - (replace-buffer-in-windows *haskell-buffer*)) - (t - nil))) - - -;;; HASKELL-INTERRUPT -;;; ------------------------------------------------------------------ - -(defun haskell-interrupt () - "Interrupt the haskell process." - (interactive) - (if (haskell-process-exists-p) - (haskell-send-to-process "\C-c"))) - - - -;;; HASKELL-EDIT-UNIT -;;; ------------------------------------------------------------------ - -(defun haskell-edit-unit () - "Edit the .hu file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (let ((find-file-not-found-hooks (list 'haskell-new-unit)) - (file-not-found nil) - (units-fname (haskell-get-unit-file-name fname))) - (find-file-other-window units-fname) - ;; If creating a new file, initialize it to contain the name - ;; of the haskell source file. - (if file-not-found - (save-excursion - (insert - (if (string= (file-name-directory fname) - (file-name-directory units-fname)) - (file-name-nondirectory fname) - fname) - "\n")))) - (haskell-mode-error "Not in a .hs buffer!")))) - -(defun haskell-new-unit () - (setq file-not-found t)) - - -;;; Look for a comment like "-- unit:" at top of file. -;;; If not found, assume unit file has same name as the buffer but -;;; a .hu extension. - -(defun haskell-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (concat (haskell-strip-file-extension fname) ".hu"))) - -(defun haskell-maybe-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (haskell-strip-file-extension fname))) - -(defun haskell-get-unit-file-name-from-file (fname) - (let ((buffer (get-file-buffer fname))) - (if buffer - (save-excursion - (beginning-of-buffer) - (if (re-search-forward "-- unit:[ \t]*" (point-max) t) - (let ((beg (match-end 0))) - (end-of-line) - (buffer-substring beg (point))) - nil)) - nil))) - - - - -;;; ================================================================== -;;; Support for printers/optimizers menus -;;; ================================================================== - -;;; This code was adapted from the standard buff-menu.el code. - -(defvar haskell-menu-mode-map nil "") - -(if (not haskell-menu-mode-map) - (progn - (setq haskell-menu-mode-map (make-keymap)) - (suppress-keymap haskell-menu-mode-map t) - (define-key haskell-menu-mode-map "m" 'hm-mark) - (define-key haskell-menu-mode-map "u" 'hm-unmark) - (define-key haskell-menu-mode-map "x" 'hm-exit) - (define-key haskell-menu-mode-map "q" 'hm-exit) - (define-key haskell-menu-mode-map " " 'next-line) - (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark) - (define-key haskell-menu-mode-map "?" 'describe-mode))) - -;; Printers Menu mode is suitable only for specially formatted data. - -(put 'haskell-menu-mode 'mode-class 'special) - -(defun haskell-menu-mode () - "Major mode for editing Haskell flags. -Each line describes a flag. -Letters do not insert themselves; instead, they are commands. -m -- mark flag (turn it on) -u -- unmark flag (turn it off) -x -- exit; tell the Haskell process to update the flags, then leave menu. -q -- exit; same as x. -Precisely,\\{haskell-menu-mode-map}" - (kill-all-local-variables) - (use-local-map haskell-menu-mode-map) - (setq truncate-lines t) - (setq buffer-read-only t) - (setq major-mode 'haskell-menu-mode) - (setq mode-name "Haskell Flags Menu") - ;; These are all initialized elsewhere - (make-local-variable 'hm-current-flags) - (make-local-variable 'hm-request-fn) - (make-local-variable 'hm-update-fn) - (run-hooks 'haskell-menu-mode-hook)) - - -(defun haskell-menu (help-file buffer request-fn update-fn) - (haskell-maybe-create-process) - (if (get-buffer buffer) - (progn - (pop-to-buffer buffer) - (goto-char (point-min))) - (progn - (pop-to-buffer buffer) - (insert-file-contents help-file) - (haskell-menu-mode) - (setq hm-request-fn request-fn) - (setq hm-update-fn update-fn) - )) - (hm-mark-current) - (message "m = mark; u = unmark; x = execute; q = quit; ? = more help.")) - - - -;;; A line that starts with *hm-marked* is a menu item turned on. -;;; A line that starts with *hm-unmarked* is turned off. -;;; A line that starts with anything else is just random text and is -;;; ignored by commands that deal with menu items. - -(defvar *hm-marked* " on") -(defvar *hm-unmarked* " ") -(defvar *hm-marked-regexp* " on \\w") -(defvar *hm-unmarked-regexp* " \\w") - -(defun hm-mark () - "Mark flag to be turned on." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-marked-regexp*) - (forward-line 1)) - ((looking-at *hm-unmarked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-unmarked*)) - (insert *hm-marked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-unmark () - "Unmark flag." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-unmarked-regexp*) - (forward-line 1)) - ((looking-at *hm-marked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-marked*)) - (insert *hm-unmarked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-backup-unmark () - "Move up and unmark." - (interactive) - (forward-line -1) - (hm-unmark) - (forward-line -1)) - - -;;; Actually make the changes. - -(defun hm-exit () - "Update flags, then leave menu." - (interactive) - (hm-execute) - (hm-quit)) - -(defun hm-execute () - "Tell haskell process to tweak flags." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((flags-on nil) - (flags-off nil)) - (while (not (eq (point) (point-max))) - (cond ((looking-at *hm-unmarked-regexp*) - (setq flags-off (cons (hm-flag) flags-off))) - ((looking-at *hm-marked-regexp*) - (setq flags-on (cons (hm-flag) flags-on))) - (t - nil)) - (forward-line 1)) - (funcall hm-update-fn flags-on flags-off)))) - - -(defun hm-quit () - (interactive) - "Make the menu go away." - (bury-buffer (current-buffer)) - (replace-buffer-in-windows (current-buffer))) - -(defun hm-flag () - (save-excursion - (beginning-of-line) - (forward-char 6) - (let ((beg (point))) - ;; End of flag name marked by tab or two spaces. - (re-search-forward "\t\\| ") - (buffer-substring beg (match-beginning 0))))) - - -;;; Update the menu to mark only those items currently turned on. - -(defun hm-mark-current () - (funcall hm-request-fn) - (save-excursion - (goto-char (point-min)) - (while (not (eq (point) (point-max))) - (cond ((and (looking-at *hm-unmarked-regexp*) - (hm-item-currently-on-p (hm-flag))) - (hm-mark)) - ((and (looking-at *hm-marked-regexp*) - (not (hm-item-currently-on-p (hm-flag)))) - (hm-unmark)) - (t - (forward-line 1)))))) - - -;;; See if a menu item is turned on. - -(defun hm-item-currently-on-p (item) - (member-string= item hm-current-flags)) - -(defun member-string= (item list) - (cond ((null list) - nil) - ((string= item (car list)) - list) - (t - (member-string= item (cdr list))))) - - - -;;; Make the menu for printers. - -(defvar *haskell-printers-help* - (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") - "Help file for printers.") - -(defvar *haskell-printers-buffer* "*Haskell printers*") - -(defun haskell-printers () - "Set printers interactively." - (interactive) - (haskell-menu - *haskell-printers-help* - *haskell-printers-buffer* - 'haskell-printers-inquire - 'haskell-printers-set)) - -(defun haskell-printers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-printers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-printers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-printers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-printers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - -;;; Equivalent stuff for the optimizers menu - -(defvar *haskell-optimizers-help* - (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") - "Help file for optimizers.") - -(defvar *haskell-optimizers-buffer* "*Haskell optimizers*") - -(defun haskell-optimizers () - "Set optimizers interactively." - (interactive) - (haskell-menu - *haskell-optimizers-help* - *haskell-optimizers-buffer* - 'haskell-optimizers-inquire - 'haskell-optimizers-set)) - -(defun haskell-optimizers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-optimizers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-optimizers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-optimizers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-optimizers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; Keep track of the association between pads, modules, and files. -;;; The global variable is a list of (pad-buffer-name module-name file-name) -;;; lists. - -(defvar *haskell-pad-mappings* () - "Associates pads with their corresponding module and file.") - -(defun haskell-record-pad-mapping (pname mname fname) - (setq *haskell-pad-mappings* - (cons (list pname mname fname) *haskell-pad-mappings*))) - -(defun haskell-get-module-from-pad (pname) - (car (cdr (assoc pname *haskell-pad-mappings*)))) - -(defun haskell-get-file-from-pad (pname) - (car (cdr (cdr (assoc pname *haskell-pad-mappings*))))) - -(defun haskell-lookup-pad (mname fname) - (let ((pname (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*))) - (if (and pname (get-buffer pname)) - pname - nil))) - -(defun haskell-lookup-pad-aux (mname fname list) - (cond ((null list) - nil) - ((and (equal mname (car (cdr (car list)))) - (equal fname (car (cdr (cdr (car list)))))) - (car (car list))) - (t - (haskell-lookup-pad-aux mname fname (cdr list))))) - - - -;;; Save any modified .hs and .hu files. -;;; Yes, the two set-buffer calls really seem to be necessary. It seems -;;; that y-or-n-p makes emacs forget we had temporarily selected some -;;; other buffer, and if you just do save-buffer directly it will end -;;; up trying to save the current buffer instead. The built-in -;;; save-some-buffers function has this problem.... - -(defun haskell-save-modified-source-files (filename) - (let ((buffers (buffer-list)) - (found-any nil)) - (while buffers - (let ((buffer (car buffers))) - (if (and (buffer-modified-p buffer) - (save-excursion - (set-buffer buffer) - (and buffer-file-name - (haskell-source-file-p buffer-file-name) - (setq found-any t) - (or (null haskell-ask-before-saving) - (and filename (string= buffer-file-name filename)) - (y-or-n-p - (format "Save file %s? " buffer-file-name)))))) - (save-excursion - (set-buffer buffer) - (save-buffer)))) - (setq buffers (cdr buffers))) - (if found-any - (message "") - (message "(No files need saving)")))) - -(defun haskell-source-file-p (filename) - (or (string-match "\\.hs$" filename) - (string-match "\\.lhs$" filename) - (string-match "\\.hi$" filename) - (string-match "\\.hu$" filename))) - - - -;;; Buffer utilities - -(defun haskell-move-marker () - "Moves the marker and point to the end of buffer" - (set-marker comint-last-input-end (point-max)) - (set-marker (process-mark (get-process "haskell")) (point-max)) - (goto-char (point-max))) - - - -;;; Extract the name of the module the point is in, from the given buffer. - -(defvar *haskell-re-module-hs* "^module\\s *") -(defvar *haskell-re-module-lhs* "^>\\s *module\\s *") -(defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*") - -(defun haskell-get-modname (buff) - "Get module name in BUFFER that point is in." - (save-excursion - (set-buffer buff) - (let ((regexp (if (haskell-lhs-filename-p (buffer-file-name)) - *haskell-re-module-lhs* - *haskell-re-module-hs*))) - (if (or (looking-at regexp) - (re-search-backward regexp (point-min) t) - (re-search-forward regexp (point-max) t)) - (progn - (goto-char (match-end 0)) - (if (looking-at *haskell-re-modname*) - (buffer-substring (match-beginning 0) (match-end 0)) - (haskell-mode-error "Module name not found!!"))) - "Main")))) - - -;;; Strip file extensions. -;;; Only strip off extensions we know about; e.g. -;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar". - -(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$") - -(defun haskell-strip-file-extension (filename) - "Strip off the extension from a filename." - (if (string-match *haskell-filename-regexp* filename) - (substring filename (match-beginning 1) (match-end 1)) - filename)) - - -;;; Is this a .lhs filename? - -(defun haskell-lhs-filename-p (filename) - (string-match ".*\\.lhs$" filename)) - - -;;; Haskell mode error - -(defun haskell-mode-error (msg) - "Show MSG in message line as an error from the haskell mode." - (error (concat "Haskell mode: " msg))) - - - -;;; ================================================================== -;;; User customization -;;; ================================================================== - -(defvar haskell-load-hook nil - "This hook is run when haskell is loaded in. -This is a good place to put key bindings." - ) - -(run-hooks 'haskell-load-hook) - - - - -;;;====================================================================== -;;; Tutorial mode setup -;;;====================================================================== - -;;; Set up additional key bindings for tutorial mode. - -(defvar ht-mode-map (make-sparse-keymap)) - -(haskell-establish-key-bindings ht-mode-map) -(define-key ht-mode-map "\C-c\C-f" 'ht-next-page) -(define-key ht-mode-map "\C-c\C-b" 'ht-prev-page) -(define-key ht-mode-map "\C-c\C-l" 'ht-restore-page) -(define-key ht-mode-map "\C-c?" 'describe-mode) - -(defun haskell-tutorial-mode () - "Major mode for running the Haskell tutorial. -You can use these commands: -\\{ht-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map ht-mode-map) - (setq major-mode 'haskell-tutorial-mode) - (setq mode-name "Haskell Tutorial") - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - - -(defun haskell-tutorial () - "Run the haskell tutorial." - (interactive) - (ht-load-tutorial) - (ht-make-buffer) - (ht-display-page) - (haskell-maybe-create-process) - (haskell-send-to-process ":(emacs-set-printers '(interactive))") - ) - - -;;; Load the tutorial file into a read-only buffer. Do not display this -;;; buffer. - -(defun ht-load-tutorial () - (let ((buffer (get-buffer *ht-file-buffer*))) - (if buffer - (save-excursion - (set-buffer buffer) - (beginning-of-buffer)) - (save-excursion - (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*))) - (let ((fname (substitute-in-file-name *ht-source-file*))) - (if (file-readable-p fname) - (ht-load-tutorial-aux fname) - (call-interactively 'ht-load-tutorial-aux))))))) - -(defun ht-load-tutorial-aux (filename) - (interactive "fTutorial file: ") - (insert-file filename) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (beginning-of-buffer)) - - -;;; Create a buffer to use for messing about with each page of the tutorial. -;;; Put the buffer into haskell-tutorial-mode. - -(defun ht-make-buffer () - (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs")) - (setq *ht-temp-buffer* (buffer-name)) - (haskell-tutorial-mode)) - - -;;; Commands for loading text into the tutorial pad buffer - -(defun ht-next-page () - "Go to the next tutorial page." - (interactive) - (if (ht-goto-next-page) - (ht-display-page) - (beep))) - -(defun ht-goto-next-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-forward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-prev-page () - "Go to the previous tutorial page." - (interactive) - (if (ht-goto-prev-page) - (ht-display-page) - (beep))) - -(defun ht-goto-prev-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-backward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-goto-page (arg) - "Go to the tutorial page specified as the argument." - (interactive "sGo to page: ") - (if (ht-searchfor-page (format "Page: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-goto-section (arg) - "Go to the tutorial section specified as the argument." - (interactive "sGo to section: ") - (if (ht-searchfor-page (format "Section: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-searchfor-page (search-string) - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (let ((point (point))) - (beginning-of-buffer) - (if (search-forward search-string nil t) - t - (progn - (goto-char point) - nil)))) - (set-buffer buff)))) - -(defun ht-restore-page () - (interactive) - (let ((old-point (point))) - (ht-display-page) - (goto-char old-point))) - -(defun ht-display-page () - (set-buffer *ht-file-buffer*) - (let* ((beg (progn - (if (search-backward "\C-l" nil t) - (forward-line 1) - (beginning-of-buffer)) - (point))) - (end (progn - (if (search-forward "\C-l" nil t) - (beginning-of-line) - (end-of-buffer)) - (point))) - (text (buffer-substring beg end))) - (set-buffer *ht-temp-buffer*) - (erase-buffer) - (insert text) - (beginning-of-buffer))) - - - -;;;====================================================================== -;;; Menu bar stuff -;;;====================================================================== - -;;; This only works in Emacs version 19, so it's in a separate file for now. - -(if (featurep 'menu-bar) - (load-library "haskell-menu")) - diff --git a/ghc/CONTRIB/haskell-modes/yale/original/README b/ghc/CONTRIB/haskell-modes/yale/original/README deleted file mode 100644 index bb22105391..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/README +++ /dev/null @@ -1,5 +0,0 @@ -This directory contains GNU Emacs support for editing Haskell files. -We don't yet have a fancy editing mode, but haskell.el contains stuff -for running Haskell as an inferior process from Emacs with key bindings -for evaluating code from buffers, etc. Look at the comments in haskell.el -for more information. diff --git a/ghc/CONTRIB/haskell-modes/yale/original/comint.el b/ghc/CONTRIB/haskell-modes/yale/original/comint.el deleted file mode 100644 index e690005aa8..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/comint.el +++ /dev/null @@ -1,1524 +0,0 @@ -;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff -;;; Copyright Olin Shivers (1988). -;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright -;;; notice appearing here to the effect that you may use this code any -;;; way you like, as long as you don't charge money for it, remove this -;;; notice, or hold me liable for its results. - -;;; The changelog is at the end of this file. - -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; - Olin Shivers (shivers@cs.cmu.edu) - -;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,... -;;; This file defines a general command-interpreter-in-a-buffer package -;;; (comint mode). The idea is that you can build specific process-in-a-buffer -;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... -;;; This way, all these specific packages share a common base functionality, -;;; and a common set of bindings, which makes them easier to use (and -;;; saves code, implementation time, etc., etc.). - -;;; Several packages are already defined using comint mode: -;;; - cmushell.el defines a shell-in-a-buffer mode. -;;; - cmulisp.el defines a simple lisp-in-a-buffer mode. -;;; Cmushell and cmulisp mode are similar to, and intended to replace, -;;; their counterparts in the standard gnu emacs release (in shell.el). -;;; These replacements are more featureful, robust, and uniform than the -;;; released versions. The key bindings in lisp mode are also more compatible -;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs). -;;; -;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. -;;; - The file tea.el tunes scheme and inferior-scheme modes for T. -;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. -;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, -;;; previewers, and printers from within emacs. -;;; - background.el allows csh-like job control inside emacs. -;;; It is pretty easy to make new derived modes for other processes. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the comments below. -;;; For further information on the standard derived modes (shell, -;;; inferior-lisp, inferior-scheme, ...), see the relevant source files. - -;;; For hints on converting existing process modes (e.g., tex-mode, -;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode -;;; instead of shell-mode, see the notes at the end of this file. - -(provide 'comint) -(defconst comint-version "2.01") - - - - - - - - - - - - - - - - - - - - - -;;; Brief Command Documentation: -;;;============================================================================ -;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp -;;; mode) -;;; -;;; m-p comint-previous-input Cycle backwards in input history -;;; m-n comint-next-input Cycle forwards -;;; m-s comint-previous-similar-input Previous similar input -;;; c-c r comint-previous-input-matching Search backwards in input history -;;; return comint-send-input -;;; c-a comint-bol Beginning of line; skip prompt. -;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. -;;; c-c c-u comint-kill-input ^u -;;; c-c c-w backward-kill-word ^w -;;; c-c c-c comint-interrupt-subjob ^c -;;; c-c c-z comint-stop-subjob ^z -;;; c-c c-\ comint-quit-subjob ^\ -;;; c-c c-o comint-kill-output Delete last batch of process output -;;; c-c c-r comint-show-output Show last batch of process output -;;; -;;; Not bound by default in comint-mode -;;; send-invisible Read a line w/o echo, and send to proc -;;; (These are bound in shell-mode) -;;; comint-dynamic-complete Complete filename at point. -;;; comint-dynamic-list-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. -;;; comint-kill-subjob No mercy. -;;; comint-continue-subjob Send CONT signal to buffer's process -;;; group. Useful if you accidentally -;;; suspend your process (with C-c C-z). -;;; -;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em. -;;; m-P comint-msearch-input Search backwards for prompt -;;; m-N comint-psearch-input Search forwards for prompt -;;; C-cR comint-msearch-input-matching Search backwards for prompt & string - -;;; comint-mode-hook is the comint mode hook. Basically for your keybindings. -;;; comint-load-hook is run after loading in this package. - - - - - -;;; Buffer Local Variables: -;;;============================================================================ -;;; Comint mode buffer local variables: -;;; comint-prompt-regexp - string comint-bol uses to match prompt. -;;; comint-last-input-end - marker For comint-kill-output command -;;; input-ring-size - integer For the input history -;;; input-ring - ring mechanism -;;; input-ring-index - marker ... -;;; comint-last-input-match - string ... -;;; comint-get-old-input - function Hooks for specific -;;; comint-input-sentinel - function process-in-a-buffer -;;; comint-input-filter - function modes. -;;; comint-input-send - function -;;; comint-eol-on-send - boolean - -(defvar comint-prompt-regexp "^" - "Regexp to recognise prompts in the inferior process. -Defaults to \"^\", the null string at BOL. - -Good choices: - Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) - Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" - franz: \"^\\(->\\|<[0-9]*>:\\) *\" - kcl: \"^>+ *\" - shell: \"^[^#$%>]*[#$%>] *\" - T: \"^>+ *\" - -This is a good thing to set in mode hooks.") - -(defvar input-ring-size 30 - "Size of input history ring.") - -;;; Here are the per-interpreter hooks. -(defvar comint-get-old-input (function comint-get-old-input-default) - "Function that submits old text in comint mode. -This function is called when return is typed while the point is in old text. -It returns the text to be submitted as process input. The default is -comint-get-old-input-default, which grabs the current line, and strips off -leading text matching comint-prompt-regexp") - -(defvar comint-input-sentinel (function ignore) - "Called on each input submitted to comint mode process by comint-send-input. -Thus it can, for instance, track cd/pushd/popd commands issued to the csh.") - -(defvar comint-input-filter - (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) - "Predicate for filtering additions to input history. -Only inputs answering true to this function are saved on the input -history list. Default is to save anything that isn't all whitespace") - -(defvar comint-input-sender (function comint-simple-send) - "Function to actually send to PROCESS the STRING submitted by user. -Usually this is just 'comint-simple-send, but if your mode needs to -massage the input string, this is your hook. This is called from -the user command comint-send-input. comint-simple-send just sends -the string plus a newline.") - -(defvar comint-eol-on-send 'T - "If non-nil, then jump to the end of the line before sending input to process. -See COMINT-SEND-INPUT") - -(defvar comint-mode-hook '() - "Called upon entry into comint-mode") - -(defvar comint-mode-map nil) - -(defun comint-mode () - "Major mode for interacting with an inferior interpreter. -Interpreter name is same as buffer name, sans the asterisks. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -Setting mode variable comint-eol-on-send means jump to the end of the line -before submitting new input. - -This mode is typically customised to create inferior-lisp-mode, -shell-mode, etc.. This can be done by setting the hooks -comint-input-sentinel, comint-input-filter, comint-input-sender and -comint-get-old-input to appropriate functions, and the variable -comint-prompt-regexp to the appropriate regular expression. - -An input history is maintained of size input-ring-size, and -can be accessed with the commands comint-next-input [\\[comint-next-input]] and -comint-previous-input [\\[comint-previous-input]]. Commands not keybound by -default are send-invisible, comint-dynamic-complete, and -comint-list-dynamic-completions. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -\\{comint-mode-map} - -Entry to this mode runs the hooks on comint-mode-hook" - (interactive) - (let ((old-ring (and (assq 'input-ring (buffer-local-variables)) - (boundp 'input-ring) - input-ring)) - (old-ptyp comint-ptyp)) ; preserve across local var kill. gross. - (kill-all-local-variables) - (setq major-mode 'comint-mode) - (setq mode-name "Comint") - (setq mode-line-process '(": %s")) - (use-local-map comint-mode-map) - (make-local-variable 'comint-last-input-end) - (setq comint-last-input-end (make-marker)) - (make-local-variable 'comint-last-input-match) - (setq comint-last-input-match "") - (make-local-variable 'comint-prompt-regexp) ; Don't set; default - (make-local-variable 'input-ring-size) ; ...to global val. - (make-local-variable 'input-ring) - (make-local-variable 'input-ring-index) - (setq input-ring-index 0) - (make-local-variable 'comint-get-old-input) - (make-local-variable 'comint-input-sentinel) - (make-local-variable 'comint-input-filter) - (make-local-variable 'comint-input-sender) - (make-local-variable 'comint-eol-on-send) - (make-local-variable 'comint-ptyp) - (setq comint-ptyp old-ptyp) - (run-hooks 'comint-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq input-ring (if (ring-p old-ring) old-ring - (make-ring input-ring-size))))) - -;;; The old-ptyp stuff above is because we have to preserve the value of -;;; comint-ptyp across calls to comint-mode, in spite of the -;;; kill-all-local-variables that it does. Blech. Hopefully, this will all -;;; go away when a later release fixes the signalling bug. - -(if comint-mode-map - nil - (setq comint-mode-map (make-sparse-keymap)) - (define-key comint-mode-map "\ep" 'comint-previous-input) - (define-key comint-mode-map "\en" 'comint-next-input) - (define-key comint-mode-map "\es" 'comint-previous-similar-input) - (define-key comint-mode-map "\C-m" 'comint-send-input) - (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) - (define-key comint-mode-map "\C-a" 'comint-bol) - (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) - (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) - (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) - (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) - (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) - (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output) - (define-key comint-mode-map "\C-cr" 'comint-previous-input-matching) - (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) - ;;; Here's the prompt-search stuff I installed for RMS to try... - (define-key comint-mode-map "\eP" 'comint-msearch-input) - (define-key comint-mode-map "\eN" 'comint-psearch-input) - (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching)) - - -;;; This function is used to make a full copy of the comint mode map, -;;; so that client modes won't interfere with each other. This function -;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions. -(defun full-copy-sparse-keymap (km) - "Recursively copy the sparse keymap KM" - (cond ((consp km) - (cons (full-copy-sparse-keymap (car km)) - (full-copy-sparse-keymap (cdr km)))) - (t km))) - -(defun comint-check-proc (buffer-name) - "True if there is a process associated w/buffer BUFFER-NAME, and -it is alive (status RUN or STOP)." - (let ((proc (get-buffer-process buffer-name))) - (and proc (memq (process-status proc) '(run stop))))) - -;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () -;;; for the second argument (program). -(defun make-comint (name program &optional startfile &rest switches) - (let* ((buffer (get-buffer-create (concat "*" name "*"))) - (proc (get-buffer-process buffer))) - ;; If no process, or nuked process, crank up a new one and put buffer in - ;; comint mode. Otherwise, leave buffer and existing process alone. - (cond ((or (not proc) (not (memq (process-status proc) '(run stop)))) - (save-excursion - (set-buffer buffer) - (comint-mode)) ; Install local vars, mode, keymap, ... - (comint-exec buffer name program startfile switches))) - buffer)) - -(defvar comint-ptyp t - "True if communications via pty; false if by pipe. Buffer local. -This is to work around a bug in emacs process signalling.") - -(defun comint-exec (buffer name command startfile switches) - "Fires up a process in buffer for comint modes. -Blasts any old process running in the buffer. Doesn't set the buffer mode. -You can use this to cheaply run a series of processes in the same comint -buffer." - (save-excursion - (set-buffer buffer) - (let ((proc (get-buffer-process buffer))) ; Blast any old process. - (if proc (delete-process proc))) - ;; Crank up a new process - (let ((proc (comint-exec-1 name buffer command switches))) - (make-local-variable 'comint-ptyp) - (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. - ;; Jump to the end, and set the process mark. - (goto-char (point-max)) - (set-marker (process-mark proc) (point))) - ;; Feed it the startfile. - (cond (startfile - ;;This is guaranteed to wait long enough - ;;but has bad results if the comint does not prompt at all - ;; (while (= size (buffer-size)) - ;; (sleep-for 1)) - ;;I hope 1 second is enough! - (sleep-for 1) - (goto-char (point-max)) - (insert-file-contents startfile) - (setq startfile (buffer-substring (point) (point-max))) - (delete-region (point) (point-max)) - (comint-send-string proc startfile))) - buffer)) - -;;; This auxiliary function cranks up the process for comint-exec in -;;; the appropriate environment. It is twice as long as it should be -;;; because emacs has two distinct mechanisms for manipulating the -;;; process environment, selected at compile time with the -;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment -;;; is bound; in the other it isn't. - -(defun comint-exec-1 (name buffer command switches) - (if (boundp 'process-environment) ; Not a completely reliable test. - (let ((process-environment - (comint-update-env process-environment - (list (format "TERMCAP=emacs:co#%d:tc=unknown" - (screen-width)) - "TERM=emacs" - "EMACS=t")))) - (apply 'start-process name buffer command switches)) - - (let ((tcapv (getenv "TERMCAP")) - (termv (getenv "TERM")) - (emv (getenv "EMACS"))) - (unwind-protect - (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown" - (screen-width))) - (setenv "TERM" "emacs") - (setenv "EMACS" "t") - (apply 'start-process name buffer command switches)) - (setenv "TERMCAP" tcapv) - (setenv "TERM" termv) - (setenv "EMACS" emv))))) - - - -;; This is just (append new old-env) that compresses out shadowed entries. -;; It's also pretty ugly, mostly due to elisp's horrible iteration structures. -(defun comint-update-env (old-env new) - (let ((ans (reverse new)) - (vars (mapcar (function (lambda (vv) - (and (string-match "^[^=]*=" vv) - (substring vv 0 (match-end 0))))) - new))) - (while old-env - (let* ((vv (car old-env)) ; vv is var=value - (var (and (string-match "^[^=]*=" vv) - (substring vv 0 (match-end 0))))) - (setq old-env (cdr old-env)) - (cond ((not (and var (comint-mem var vars))) - (if var (setq var (cons var vars))) - (setq ans (cons vv ans)))))) - (nreverse ans))) - -;;; This should be in emacs, but it isn't. -(defun comint-mem (item list &optional elt=) - "Test to see if ITEM is equal to an item in LIST. -Option comparison function ELT= defaults to equal." - (let ((elt= (or elt= (function equal))) - (done nil)) - (while (and list (not done)) - (if (funcall elt= item (car list)) - (setq done list) - (setq list (cdr list)))) - done)) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -;;; Ring Code -;;;============================================================================ -;;; This code defines a ring data structure. A ring is a -;;; (hd-index tl-index . vector) -;;; list. You can insert to, remove from, and rotate a ring. When the ring -;;; fills up, insertions cause the oldest elts to be quietly dropped. -;;; -;;; HEAD = index of the newest item on the ring. -;;; TAIL = index of the oldest item on the ring. -;;; -;;; These functions are used by the input history mechanism, but they can -;;; be used for other purposes as well. - -(defun ring-p (x) - "T if X is a ring; NIL otherwise." - (and (consp x) (integerp (car x)) - (consp (cdr x)) (integerp (car (cdr x))) - (vectorp (cdr (cdr x))))) - -(defun make-ring (size) - "Make a ring that can contain SIZE elts" - (cons 1 (cons 0 (make-vector (+ size 1) nil)))) - -(defun ring-plus1 (index veclen) - "INDEX+1, with wraparound" - (let ((new-index (+ index 1))) - (if (= new-index veclen) 0 new-index))) - -(defun ring-minus1 (index veclen) - "INDEX-1, with wraparound" - (- (if (= 0 index) veclen index) 1)) - -(defun ring-length (ring) - "Number of elts in the ring." - (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring))))) - (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd))))) - (if (= len siz) 0 len)))) - -(defun ring-empty-p (ring) - (= 0 (ring-length ring))) - -(defun ring-insert (ring item) - "Insert a new item onto the ring. If the ring is full, dump the oldest -item to make room." - (let* ((vec (cdr (cdr ring))) (len (length vec)) - (new-hd (ring-minus1 (car ring) len))) - (setcar ring new-hd) - (aset vec new-hd item) - (if (ring-empty-p ring) ;overflow -- dump one off the tail. - (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len))))) - -(defun ring-remove (ring) - "Remove the oldest item retained on the ring." - (if (ring-empty-p ring) (error "Ring empty") - (let ((tl (car (cdr ring))) (vec (cdr (cdr ring)))) - (set-car (cdr ring) (ring-minus1 tl (length vec))) - (aref vec tl)))) - -;;; This isn't actually used in this package. I just threw it in in case -;;; someone else wanted it. If you want rotating-ring behavior on your history -;;; retrieval (analagous to kill ring behavior), this function is what you -;;; need. I should write the yank-input and yank-pop-input-or-kill to go with -;;; this, and not bind it to a key by default, so it would be available to -;;; people who want to bind it to a key. But who would want it? Blech. -(defun ring-rotate (ring n) - (if (not (= n 0)) - (if (ring-empty-p ring) ;Is this the right error check? - (error "ring empty") - (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))) - (let ((len (length vec))) - (while (> n 0) - (setq tl (ring-plus1 tl len)) - (aset ring tl (aref ring hd)) - (setq hd (ring-plus1 hd len)) - (setq n (- n 1))) - (while (< n 0) - (setq hd (ring-minus1 hd len)) - (aset vec hd (aref vec tl)) - (setq tl (ring-minus1 tl len)) - (setq n (- n 1)))) - (set-car ring hd) - (set-car (cdr ring) tl))))) - -(defun comint-mod (n m) - "Returns N mod M. M is positive. Answer is guaranteed to be non-negative, -and less than m." - (let ((n (% n m))) - (if (>= n 0) n - (+ n - (if (>= m 0) m (- m)))))) ; (abs m) - -(defun ring-ref (ring index) - (let ((numelts (ring-length ring))) - (if (= numelts 0) (error "indexed empty ring") - (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))) - (index (comint-mod index numelts)) - (vec-index (comint-mod (+ index hd) - (length vec)))) - (aref vec vec-index))))) - - -;;; Input history retrieval commands -;;; M-p -- previous input M-n -- next input -;;; C-c r -- previous input matching -;;; =========================================================================== - -(defun comint-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length input-ring))) - (cond ((<= len 0) - (message "Empty input ring") - (ding)) - ((not (comint-after-pmark-p)) - (message "Not after process mark") - (ding)) - (t - (cond ((eq last-command 'comint-previous-input) - (delete-region (mark) (point))) - ((eq last-command 'comint-previous-similar-input) - (delete-region - (process-mark (get-buffer-process (current-buffer))) - (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (message "%d" (1+ input-ring-index)) - (insert (ring-ref input-ring input-ring-index)) - (setq this-command 'comint-previous-input))))) - -(defun comint-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (comint-previous-input (- arg))) - -(defvar comint-last-input-match "" - "Last string searched for by comint input history search, for defaulting. -Buffer local variable.") - -(defun comint-previous-input-matching (str) - "Searches backwards through input history for substring match." - (interactive (let* ((last-command last-command) ; preserve around r-f-m - (s (read-from-minibuffer - (format "Command substring (default %s): " - comint-last-input-match)))) - (list (if (string= s "") comint-last-input-match s)))) -; (interactive "sCommand substring: ") - (setq comint-last-input-match str) ; update default - (if (not (eq last-command 'comint-previous-input)) - (setq input-ring-index -1)) - (let ((str (regexp-quote str)) - (len (ring-length input-ring)) - (n (+ input-ring-index 1))) - (while (and (< n len) (not (string-match str (ring-ref input-ring n)))) - (setq n (+ n 1))) - (cond ((< n len) - (comint-previous-input (- n input-ring-index))) - (t (if (eq last-command 'comint-previous-input) - (setq this-command 'comint-previous-input)) - (message "Not found.") - (ding))))) - - -;;; These next three commands are alternatives to the input history commands -- -;;; comint-next-input, comint-previous-input and -;;; comint-previous-input-matching. They search through the process buffer -;;; text looking for occurrences of the prompt. RMS likes them better; -;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for -;;; now. Try'em out. Go with what you like... - -;;; comint-msearch-input-matching prompts for a string, not a regexp. -;;; This could be considered to be the wrong thing. I decided to keep it -;;; simple, and not make the user worry about regexps. This, of course, -;;; limits functionality. - -(defun comint-psearch-input () - "Search forwards for next occurrence of prompt and skip to end of line. -\(prompt is anything matching regexp comint-prompt-regexp)" - (interactive) - (if (re-search-forward comint-prompt-regexp (point-max) t) - (end-of-line) - (error "No occurrence of prompt found"))) - -(defun comint-msearch-input () - "Search backwards for previous occurrence of prompt and skip to end of line. -Search starts from beginning of current line." - (interactive) - (let ((p (save-excursion - (beginning-of-line) - (cond ((re-search-backward comint-prompt-regexp (point-min) t) - (end-of-line) - (point)) - (t nil))))) - (if p (goto-char p) - (error "No occurrence of prompt found")))) - -(defun comint-msearch-input-matching (str) - "Search backwards for occurrence of prompt followed by STRING. -STRING is prompted for, and is NOT a regular expression." - (interactive (let ((s (read-from-minibuffer - (format "Command (default %s): " - comint-last-input-match)))) - (list (if (string= s "") comint-last-input-match s)))) -; (interactive "sCommand: ") - (setq comint-last-input-match str) ; update default - (let* ((r (concat comint-prompt-regexp (regexp-quote str))) - (p (save-excursion - (beginning-of-line) - (cond ((re-search-backward r (point-min) t) - (end-of-line) - (point)) - (t nil))))) - (if p (goto-char p) - (error "No match")))) - -;;; -;;; Similar input -- contributed by ccm and highly winning. -;;; -;;; Reenter input, removing back to the last insert point if it exists. -;;; -(defvar comint-last-similar-string "" - "The string last used in a similar string search.") -(defun comint-previous-similar-input (arg) - "Reenters the last input that matches the string typed so far. If repeated -successively older inputs are reentered. If arg is 1, it will go back -in the history, if -1 it will go forward." - (interactive "p") - (if (not (comint-after-pmark-p)) - (error "Not after process mark")) - (if (not (eq last-command 'comint-previous-similar-input)) - (setq input-ring-index -1 - comint-last-similar-string - (buffer-substring - (process-mark (get-buffer-process (current-buffer))) - (point)))) - (let* ((size (length comint-last-similar-string)) - (len (ring-length input-ring)) - (n (+ input-ring-index arg)) - entry) - (while (and (< n len) - (or (< (length (setq entry (ring-ref input-ring n))) size) - (not (equal comint-last-similar-string - (substring entry 0 size))))) - (setq n (+ n arg))) - (cond ((< n len) - (setq input-ring-index n) - (if (eq last-command 'comint-previous-similar-input) - (delete-region (mark) (point)) ; repeat - (push-mark (point))) ; 1st time - (insert (substring entry size))) - (t (message "Not found.") (ding) (sit-for 1))) - (message "%d" (1+ input-ring-index)))) - - - - - - - - - -(defun comint-send-input () - "Send input to process. After the process output mark, sends all text -from the process mark to point as input to the process. Before the -process output mark, calls value of variable comint-get-old-input to retrieve -old input, copies it to the end of the buffer, and sends it. A terminal -newline is also inserted into the buffer and sent to the process. In either -case, value of variable comint-input-sentinel is called on the input before -sending it. The input is entered into the input history ring, if value of -variable comint-input-filter returns non-nil when called on the input. - -If variable comint-eol-on-send is non-nil, then point is moved to the end of -line before sending the input. - -comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen -according to the command interpreter running in the buffer. E.g., -If the interpreter is the csh, - comint-get-old-input is the default: take the current line, discard any - initial string matching regexp comint-prompt-regexp. - comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\" - commands. When it sees one, it cd's the buffer. - comint-input-filter is the default: returns T if the input isn't all white - space. - -If the comint is Lucid Common Lisp, - comint-get-old-input snarfs the sexp ending at point. - comint-input-sentinel does nothing. - comint-input-filter returns NIL if the input matches input-filter-regexp, - which matches (1) all whitespace (2) :a, :c, etc. - -Similarly for Soar, Scheme, etc.." - (interactive) - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (progn (if comint-eol-on-send (end-of-line)) - (buffer-substring pmark (point))) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (funcall comint-input-sender proc input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)))))) - -(defun comint-get-old-input-default () - "Default for comint-get-old-input: take the current line, and discard -any initial text matching comint-prompt-regexp." - (save-excursion - (beginning-of-line) - (comint-skip-prompt) - (let ((beg (point))) - (end-of-line) - (buffer-substring beg (point))))) - -(defun comint-skip-prompt () - "Skip past the text matching regexp comint-prompt-regexp. -If this takes us past the end of the current line, don't skip at all." - (let ((eol (save-excursion (end-of-line) (point)))) - (if (and (looking-at comint-prompt-regexp) - (<= (match-end 0) eol)) - (goto-char (match-end 0))))) - - -(defun comint-after-pmark-p () - "Is point after the process output marker?" - ;; Since output could come into the buffer after we looked at the point - ;; but before we looked at the process marker's value, we explicitly - ;; serialise. This is just because I don't know whether or not emacs - ;; services input during execution of lisp commands. - (let ((proc-pos (marker-position - (process-mark (get-buffer-process (current-buffer)))))) - (<= proc-pos (point)))) - -(defun comint-simple-send (proc string) - "Default function for sending to PROC input STRING. -This just sends STRING plus a newline. To override this, -set the hook COMINT-INPUT-SENDER." - (comint-send-string proc string) - (comint-send-string proc "\n")) - -(defun comint-bol (arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If a prefix argument is given (\\[universal-argument]), then no prompt skip --- go straight to column 0. - -The prompt skip is done by skipping text matching the regular expression -comint-prompt-regexp, a buffer local variable. - -If you don't like this command, reset c-a to beginning-of-line -in your hook, comint-mode-hook." - (interactive "P") - (beginning-of-line) - (if (null arg) (comint-skip-prompt))) - -;;; These two functions are for entering text you don't want echoed or -;;; saved -- typically passwords to ftp, telnet, or somesuch. -;;; Just enter m-x send-invisible and type in your line. - -(defun comint-read-noecho (prompt) - "Prompt the user with argument PROMPT. Read a single line of text -without echoing, and return it. Note that the keystrokes comprising -the text can still be recovered (temporarily) with \\[view-lossage]. This -may be a security bug for some applications." - (let ((echo-keystrokes 0) - (answ "") - tem) - (if (and (stringp prompt) (not (string= (message prompt) ""))) - (message prompt)) - (while (not(or (= (setq tem (read-char)) ?\^m) - (= tem ?\n))) - (setq answ (concat answ (char-to-string tem)))) - (message "") - answ)) - -(defun send-invisible (str) - "Read a string without echoing, and send it to the process running -in the current buffer. A new-line is additionally sent. String is not -saved on comint input history list. -Security bug: your string can still be temporarily recovered with -\\[view-lossage]." -; (interactive (list (comint-read-noecho "Enter non-echoed text"))) - (interactive "P") ; Defeat snooping via C-x esc - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (comint-send-string proc - (if (stringp str) str - (comint-read-noecho "Enter non-echoed text"))) - (comint-send-string proc "\n")))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -;;; Low-level process communication - -(defvar comint-input-chunk-size 512 - "*Long inputs send to comint processes are broken up into chunks of this size. -If your process is choking on big inputs, try lowering the value.") - -(defun comint-send-string (proc str) - "Send PROCESS the contents of STRING as input. -This is equivalent to process-send-string, except that long input strings -are broken up into chunks of size comint-input-chunk-size. Processes -are given a chance to output between chunks. This can help prevent processes -from hanging when you send them long inputs on some OS's." - (let* ((len (length str)) - (i (min len comint-input-chunk-size))) - (process-send-string proc (substring str 0 i)) - (while (< i len) - (let ((next-i (+ i comint-input-chunk-size))) - (accept-process-output) - (process-send-string proc (substring str i (min len next-i))) - (setq i next-i))))) - -(defun comint-send-region (proc start end) - "Sends to PROC the region delimited by START and END. -This is a replacement for process-send-region that tries to keep -your process from hanging on long inputs. See comint-send-string." - (comint-send-string proc (buffer-substring start end))) - - - - - - - - - - - - - - - - - - -;;; Random input hackage - -(defun comint-kill-output () - "Kill all output from interpreter since last input." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (kill-region comint-last-input-end pmark) - (goto-char pmark) - (insert "*** output flushed ***\n") - (set-marker pmark (point)))) - -(defun comint-show-output () - "Display start of this batch of interpreter output at top of window. -Also put cursor there." - (interactive) - (goto-char comint-last-input-end) - (backward-char) - (beginning-of-line) - (set-window-start (selected-window) (point)) - (end-of-line)) - -(defun comint-interrupt-subjob () - "Interrupt the current subjob." - (interactive) - (interrupt-process nil comint-ptyp)) - -(defun comint-kill-subjob () - "Send kill signal to the current subjob." - (interactive) - (kill-process nil comint-ptyp)) - -(defun comint-quit-subjob () - "Send quit signal to the current subjob." - (interactive) - (quit-process nil comint-ptyp)) - -(defun comint-stop-subjob () - "Stop the current subjob. -WARNING: if there is no current subjob, you can end up suspending -the top-level process running in the buffer. If you accidentally do -this, use \\[comint-continue-subjob] to resume the process. (This -is not a problem with most shells, since they ignore this signal.)" - (interactive) - (stop-process nil comint-ptyp)) - -(defun comint-continue-subjob () - "Send CONT signal to process buffer's process group. -Useful if you accidentally suspend the top-level process." - (interactive) - (continue-process nil comint-ptyp)) - -(defun comint-kill-input () - "Kill all text from last stuff output by interpreter to point." - (interactive) - (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) - (p-pos (marker-position pmark))) - (if (> (point) p-pos) - (kill-region pmark (point))))) - -(defun comint-delchar-or-maybe-eof (arg) - "Delete ARG characters forward, or send an EOF to process if at end of buffer." - (interactive "p") - (if (eobp) - (process-send-eof) - (delete-char arg))) - - - - - - - - - - - - - - - - - - - - - - - -;;; Support for source-file processing commands. -;;;============================================================================ -;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have -;;; commands that process files of source text (e.g. loading or compiling -;;; files). So the corresponding process-in-a-buffer modes have commands -;;; for doing this (e.g., lisp-load-file). The functions below are useful -;;; for defining these commands. -;;; -;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme -;;; and Soar, in that they don't know anything about file extensions. -;;; So the compile/load interface gets the wrong default occasionally. -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). - - -;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing -;;; commands. -;;; -;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you -;;; want to save the buffer before issuing any process requests to the command -;;; interpreter. -;;; -;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt -;;; for the file to process. - -;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) -;;;============================================================================ -;;; This function computes the defaults for the load-file and compile-file -;;; commands for tea, soar, cmulisp, and cmuscheme modes. -;;; -;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last -;;; source-file processing command. NIL if there hasn't been one yet. -;;; - SOURCE-MODES is a list used to determine what buffers contain source -;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. -;;; Typically, (lisp-mode) or (scheme-mode). -;;; -;;; If the command is given while the cursor is inside a string, *and* -;;; the string is an existing filename, *and* the filename is not a directory, -;;; then the string is taken as default. This allows you to just position -;;; your cursor over a string that's a filename and have it taken as default. -;;; -;;; If the command is given in a file buffer whose major mode is in -;;; SOURCE-MODES, then the the filename is the default file, and the -;;; file's directory is the default directory. -;;; -;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), -;;; then the default directory & file are what was used in the last source-file -;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time -;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory -;;; is the cwd, with no default file. (\"no default file\" = nil) -;;; -;;; SOURCE-REGEXP is typically going to be something like (tea-mode) -;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) -;;; for Soar programs, etc. -;;; -;;; The function returns a pair: (default-directory . default-file). - -(defun comint-source-default (previous-dir/file source-modes) - (cond ((and buffer-file-name (memq major-mode source-modes)) - (cons (file-name-directory buffer-file-name) - (file-name-nondirectory buffer-file-name))) - (previous-dir/file) - (t - (cons default-directory nil)))) - - -;;; (COMINT-CHECK-SOURCE fname) -;;;============================================================================ -;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU -;;; process-in-a-buffer modes), this function can be called on the filename. -;;; If the file is loaded into a buffer, and the buffer is modified, the user -;;; is queried to see if he wants to save the buffer before proceeding with -;;; the load or compile. - -(defun comint-check-source (fname) - (let ((buff (get-file-buffer fname))) - (if (and buff - (buffer-modified-p buff) - (y-or-n-p (format "Save buffer %s first? " - (buffer-name buff)))) - ;; save BUFF. - (let ((old-buffer (current-buffer))) - (set-buffer buff) - (save-buffer) - (set-buffer old-buffer))))) - - -;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) -;;;============================================================================ -;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter -;;; commands that process source files (like loading or compiling a file). -;;; It prompts for the filename, provides a default, if there is one, -;;; and returns the result filename. -;;; -;;; See COMINT-SOURCE-DEFAULT for more on determining defaults. -;;; -;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair -;;; from the last source processing command. SOURCE-MODES is a list of major -;;; modes used to determine what file buffers contain source files. (These -;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, -;;; then the filename reader will only accept a file that exists. -;;; -;;; A typical use: -;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file -;;; '(lisp-mode) t)) - -;;; This is pretty stupid about strings. It decides we're in a string -;;; if there's a quote on both sides of point on the current line. -(defun comint-extract-string () - "Returns string around point that starts the current line or nil." - (save-excursion - (let* ((point (point)) - (bol (progn (beginning-of-line) (point))) - (eol (progn (end-of-line) (point))) - (start (progn (goto-char point) - (and (search-backward "\"" bol t) - (1+ (point))))) - (end (progn (goto-char point) - (and (search-forward "\"" eol t) - (1- (point)))))) - (and start end - (buffer-substring start end))))) - -(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) - (let* ((def (comint-source-default prev-dir/file source-modes)) - (stringfile (comint-extract-string)) - (sfile-p (and stringfile - (file-exists-p stringfile) - (not (file-directory-p stringfile)))) - (defdir (if sfile-p (file-name-directory stringfile) - (car def))) - (deffile (if sfile-p (file-name-nondirectory stringfile) - (cdr def))) - (ans (read-file-name (if deffile (format "%s(default %s) " - prompt deffile) - prompt) - defdir - (concat defdir deffile) - mustmatch-p))) - (list (expand-file-name (substitute-in-file-name ans))))) - -;;; I am somewhat divided on this string-default feature. It seems -;;; to violate the principle-of-least-astonishment, in that it makes -;;; the default harder to predict, so you actually have to look and see -;;; what the default really is before choosing it. This can trip you up. -;;; On the other hand, it can be useful, I guess. I would appreciate feedback -;;; on this. -;;; -Olin - - - - - - - - - - - - - - - - - - - - - - - -;;; Simple process query facility. -;;; =========================================================================== -;;; This function is for commands that want to send a query to the process -;;; and show the response to the user. For example, a command to get the -;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query -;;; to an inferior Common Lisp process. -;;; -;;; This simple facility just sends strings to the inferior process and pops -;;; up a window for the process buffer so you can see what the process -;;; responds with. We don't do anything fancy like try to intercept what the -;;; process responds with and put it in a pop-up window or on the message -;;; line. We just display the buffer. Low tech. Simple. Works good. - -;;; Send to the inferior process PROC the string STR. Pop-up but do not select -;;; a window for the inferior process so that its response can be seen. -(defun comint-proc-query (proc str) - (let* ((proc-buf (process-buffer proc)) - (proc-mark (process-mark proc))) - (display-buffer proc-buf) - (set-buffer proc-buf) ; but it's not the selected *window* - (let ((proc-win (get-buffer-window proc-buf)) - (proc-pt (marker-position proc-mark))) - (comint-send-string proc str) ; send the query - (accept-process-output proc) ; wait for some output - ;; Try to position the proc window so you can see the answer. - ;; This is bogus code. If you delete the (sit-for 0), it breaks. - ;; I don't know why. Wizards invited to improve it. - (if (not (pos-visible-in-window-p proc-pt proc-win)) - (let ((opoint (window-point proc-win))) - (set-window-point proc-win proc-mark) (sit-for 0) - (if (not (pos-visible-in-window-p opoint proc-win)) - (push-mark opoint) - (set-window-point proc-win opoint))))))) - - - - - - - - - - - -;;; Filename completion in a buffer -;;; =========================================================================== -;;; Useful completion functions, courtesy of the Ergo group. -;;; M-<Tab> will complete the filename at the cursor as much as possible -;;; M-? will display a list of completions in the help buffer. - -;;; Three commands: -;;; comint-dynamic-complete Complete filename at point. -;;; comint-dynamic-list-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. - -;;; These are not installed in the comint-mode keymap. But they are -;;; available for people who want them. Shell-mode installs them: -;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete) -;;; (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions))) -;;; -;;; Commands like this are fine things to put in load hooks if you -;;; want them present in specific modes. Example: -;;; (setq cmushell-load-hook -;;; '((lambda () (define-key lisp-mode-map "\M-\t" -;;; 'comint-replace-by-expanded-filename)))) -;;; - - -(defun comint-match-partial-pathname () - "Returns the string of an existing filename or causes an error." - (if (save-excursion (backward-char 1) (looking-at "\\s ")) "" - (save-excursion - (re-search-backward "[^~/A-Za-z0-9---_.$#,]+") - (re-search-forward "[~/A-Za-z0-9---_.$#,]+") - (substitute-in-file-name - (buffer-substring (match-beginning 0) (match-end 0)))))) - - -(defun comint-replace-by-expanded-filename () -"Replace the filename at point with an expanded, canonicalised, and -completed replacement. -\"Expanded\" means environment variables (e.g., $HOME) and ~'s are -replaced with the corresponding directories. \"Canonicalised\" means .. -and \. are removed, and the filename is made absolute instead of relative. -See functions expand-file-name and substitute-in-file-name. See also -comint-dynamic-complete." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completion (file-name-completion pathnondir - (or pathdir default-directory)))) - (cond ((null completion) - (message "No completions of %s." pathname) - (ding)) - ((eql completion t) - (message "Unique completion.")) - (t ; this means a string was returned. - (delete-region (match-beginning 0) (match-end 0)) - (insert (expand-file-name (concat pathdir completion))))))) - - -(defun comint-dynamic-complete () - "Dynamically complete the filename at point. -This function is similar to comint-replace-by-expanded-filename, except -that it won't change parts of the filename already entered in the buffer; -it just adds completion characters to the end of the filename." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completion (file-name-completion pathnondir - (or pathdir default-directory)))) - (cond ((null completion) - (message "No completions of %s." pathname) - (ding)) - ((eql completion t) - (message "Unique completion.")) - (t ; this means a string was returned. - (goto-char (match-end 0)) - (insert (substring completion (length pathnondir))))))) - -(defun comint-dynamic-list-completions () - "List in help buffer all possible completions of the filename at point." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completions - (file-name-all-completions pathnondir - (or pathdir default-directory)))) - (cond ((null completions) - (message "No completions of %s." pathname) - (ding)) - (t - (let ((conf (current-window-configuration))) - (with-output-to-temp-buffer "*Help*" - (display-completion-list completions)) - (sit-for 0) - (message "Hit space to flush.") - (let ((ch (read-char))) - (if (= ch ?\ ) - (set-window-configuration conf) - (setq unread-command-char ch)))))))) - -; Ergo bindings -; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename) -; (global-set-key "\M-?" 'comint-dynamic-list-completions) -; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) - - - - - - - - - - - - - - - - - - - - - - - - - - -;;; Converting process modes to use comint mode -;;; =========================================================================== -;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, -;;; telnet are some) use the shell package as clients. Most of them would -;;; be better off using the comint package, but they predate it. -;;; -;;; Altering these packages to use comint mode should greatly -;;; improve their functionality, and is fairly easy. -;;; -;;; Renaming variables -;;; Most of the work is renaming variables and functions. These are the common -;;; ones: -;;; Local variables: -;;; last-input-end comint-last-input-end -;;; last-input-start <unnecessary> -;;; shell-prompt-pattern comint-prompt-regexp -;;; shell-set-directory-error-hook <no equivalent> -;;; Miscellaneous: -;;; shell-set-directory <unnecessary> -;;; shell-mode-map comint-mode-map -;;; Commands: -;;; shell-send-input comint-send-input -;;; shell-send-eof comint-delchar-or-maybe-eof -;;; kill-shell-input comint-kill-input -;;; interrupt-shell-subjob comint-interrupt-subjob -;;; stop-shell-subjob comint-stop-subjob -;;; quit-shell-subjob comint-quit-subjob -;;; kill-shell-subjob comint-kill-subjob -;;; kill-output-from-shell comint-kill-output -;;; show-output-from-shell comint-show-output -;;; copy-last-shell-input Use comint-previous-input/comint-next-input -;;; -;;; LAST-INPUT-START is no longer necessary because inputs are stored on the -;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken -;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel. -;;; Comint mode does not provide functionality equivalent to -;;; shell-set-directory-error-hook; it is gone. -;;; -;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do -;;; *not* create the comint-mode local variables in your foo-mode function. -;;; This is not modular. Instead, call comint-mode, and let *it* create the -;;; necessary comint-specific local variables. Then create the -;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to -;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks -;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel, -;;; comint-get-old-input) that need to be different from the defaults. Call -;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; -;;; comint-mode will take care of it. The following example, from cmushell.el, -;;; is typical: -;;; -;;; (defun shell-mode () -;;; (interactive) -;;; (comint-mode) -;;; (setq comint-prompt-regexp shell-prompt-pattern) -;;; (setq major-mode 'shell-mode) -;;; (setq mode-name "Shell") -;;; (cond ((not shell-mode-map) -;;; (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map)) -;;; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'comint-dynamic-list-completions))) -;;; (use-local-map shell-mode-map) -;;; (make-local-variable 'shell-directory-stack) -;;; (setq shell-directory-stack nil) -;;; (setq comint-input-sentinel 'shell-directory-tracker) -;;; (run-hooks 'shell-mode-hook)) -;;; -;;; -;;; Note that make-comint is different from make-shell in that it -;;; doesn't have a default program argument. If you give make-shell -;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, -;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument -;;; of NIL, it barfs. Adjust your code accordingly... -;;; - - - - - - - - - - - - - - -;;; Do the user's customisation... - -(defvar comint-load-hook nil - "This hook is run when comint is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'comint-load-hook) - -;;; Change log: -;;; 9/12/89 -;;; - Souped up the filename expansion procedures. -;;; Doc strings are much clearer and more detailed. -;;; Fixed a bug where doing a filename completion when the point -;;; was in the middle of the filename instead of at the end would lose. -;;; -;;; 2/17/90 -;;; - Souped up the command history stuff so that text inserted -;;; by comint-previous-input-matching is removed by following -;;; command history recalls. comint-next/previous-input-matching -;;; is now much more smoothly integrated w/the command history stuff. -;;; - Added comint-eol-on-send flag and comint-input-sender hook. -;;; Comint-input-sender based on code contributed by Jeff Peck -;;; (peck@sun.com). -;;; -;;; 3/13/90 ccm@cmu.cs.edu -;;; - Added comint-previous-similar-input for looking up similar inputs. -;;; - Added comint-send-and-get-output to allow snarfing input from -;;; buffer. -;;; - Added the ability to pick up a source file by positioning over -;;; a string in comint-get-source. -;;; - Added add-hook to make it a little easier for the user to use -;;; multiple hooks. -;;; -;;; 5/22/90 shivers -;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el. -;;; - Altered Chris' comint-get-source string feature. The string -;;; is only offered as a default if it names an existing file. -;;; - Changed comint-exec to directly crank up the process, instead -;;; of calling the env program. This made background.el happy. -;;; - Added new buffer-local var comint-ptyp. The problem is that -;;; the signalling functions don't work as advertised. If you are -;;; communicating via pipes, the CURRENT-GROUP arg is supposed to -;;; be ignored, but, unfortunately it seems to be the case that you -;;; must pass a NIL for this arg in the pipe case. COMINT-PTYP -;;; is a flag that tells whether the process is communicating -;;; via pipes or a pty. The comint signalling functions use it -;;; to determine the necessary CURRENT-GROUP arg value. The bug -;;; has been reported to the Gnu folks. -;;; - comint-dynamic-complete flushes the help window if you hit space -;;; after you execute it. -;;; - Added functions comint-send-string, comint-send-region and var -;;; comint-input-chunk-size. comint-send-string tries to prevent processes -;;; from hanging when you send them long strings by breaking them into -;;; chunks and allowing process output between chunks. I got the idea from -;;; Eero Simoncelli's Common Lisp package. Note that using -;;; comint-send-string means that the process buffer's contents can change -;;; during a call! If you depend on process output only happening between -;;; toplevel commands, this could be a problem. In such a case, use -;;; process-send-string instead. If this is a problem for people, I'd like -;;; to hear about it. -;;; - Added comint-proc-query as a simple mechanism for commands that -;;; want to query an inferior process and display its response. For a -;;; typical use, see lisp-show-arglist in cmulisp.el. -;;; - Added constant comint-version, which is now "2.01". -;;; -;;; 6/14/90 shivers -;;; - Had comint-update-env defined twice. Removed extra copy. Also -;;; renamed mem to be comint-mem, for modularity. The duplication -;;; was reported by Michael Meissner. -;;; 6/16/90 shivers -;;; - Emacs has two different mechanisms for maintaining the process -;;; environment, determined at compile time by the MAINTAIN-ENVIRONMENT -;;; #define. One uses the process-environment global variable, and -;;; one uses a getenv/setenv interface. comint-exec assumed the -;;; process-environment interface; it has been generalised (with -;;; comint-exec-1) to handle both cases. Pretty bogus. We could, -;;; of course, skip all this and just use the etc/env program to -;;; handle the environment tweaking, but that obscures process -;;; queries that other modules (like background.el) depend on. etc/env -;;; is also fairly bogus. This bug, and some of the fix code was -;;; reported by Dan Pierson. -;;; -;;; 9/5/90 shivers -;;; - Changed make-variable-buffer-local's to make-local-variable's. -;;; This leaves non-comint-mode buffers alone. Stephane Payrard -;;; reported the sloppy useage. -;;; - You can now go from comint-previous-similar-input to -;;; comint-previous-input with no problem. - - diff --git a/ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el b/ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el deleted file mode 100644 index 9f851c683c..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el +++ /dev/null @@ -1,43 +0,0 @@ -;;; haskell-menu.el -- support for Haskell menubar functions -;;; -;;; author : Sandra Loosemore -;;; date : 15 Jun 1994 -;;; - - -;;; Add an entry to the main menu bar - -(defvar menu-bar-haskell-menu (make-sparse-keymap "Haskell")) -(define-key haskell-mode-map [menu-bar haskell] - (cons "Haskell" menu-bar-haskell-menu)) -(define-key inferior-haskell-mode-map [menu-bar haskell] - (cons "Haskell" menu-bar-haskell-menu)) -(define-key ht-mode-map [menu-bar haskell] - (cons "Haskell" menu-bar-haskell-menu)) - - -;;; Define the functions. They get listed on the menu in the reverse -;;; order that they're defined. - -(define-key menu-bar-haskell-menu [haskell-tutorial] - '("Tutorial" . haskell-tutorial)) -(define-key menu-bar-haskell-menu [haskell-optimizers] - '("Optimizers..." . haskell-optimizers)) -(define-key menu-bar-haskell-menu [haskell-printers] - '("Printers..." . haskell-printers)) -(define-key menu-bar-haskell-menu [haskell-get-pad] - '("Scratch Pad" . haskell-get-pad)) -(define-key menu-bar-haskell-menu [haskell-compile] - '("Compile File..." . haskell-compile)) -(define-key menu-bar-haskell-menu [haskell-run-file] - '("Run File..." . haskell-run-file)) -(define-key menu-bar-haskell-menu [haskell-load] - '("Load File..." . haskell-load)) -(define-key menu-bar-haskell-menu [haskell-report-type] - '("Type Check Expression..." . haskell-report-type)) -(define-key menu-bar-haskell-menu [haskell-run] - '("Run Dialogue..." . haskell-run)) -(define-key menu-bar-haskell-menu [haskell-eval] - '("Eval Expression..." . haskell-eval)) - -(provide 'haskell-menu) diff --git a/ghc/CONTRIB/haskell-modes/yale/original/haskell.el b/ghc/CONTRIB/haskell-modes/yale/original/haskell.el deleted file mode 100644 index 9b4c95b3ca..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/haskell.el +++ /dev/null @@ -1,1710 +0,0 @@ -;;; ================================================================== -;;; File: haskell.el ;;; -;;; ;;; -;;; Author: A. Satish Pai ;;; -;;; Maria M. Gutierrez ;;; -;;; Dan Rabin (Jul-1991) ;;; -;;; ================================================================== - -;;; Description: Haskell mode for GNU Emacs. - -;;; Related files: comint.el - -;;; Contents: - -;;; Update Log - -;;; Known bugs / problems -;;; - the haskell editing mode (indentation, etc) is still missing. -;;; - the handling for errors from haskell needs to be rethought. -;;; - general cleanup of code. - - -;;; Errors generated - -;;; ================================================================== -;;; Haskell mode for editing files, and an Inferior Haskell mode to -;;; run a Haskell process. This file contains stuff snarfed and -;;; modified from tea.el, scheme.el, etc. This file may be freely -;;; modified; however, if you have any bug-corrections or useful -;;; improvements, I'd appreciate it if you sent me the mods so that -;;; I can merge them into the version I maintain. -;;; -;;; The inferior Haskell mode requires comint.el. -;;; -;;; You might want to add this to your .emacs to go automagically -;;; into Haskell mode while finding .hs files. -;;; -;;; (setq auto-mode-alist -;;; (cons '("\\.hs$" . haskell-mode) -;;; auto-mode-alist)_) -;;; -;;; To use this file, set up your .emacs to autoload this file for -;;; haskell-mode. For example: -;;; -;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; [Note: The path name given above is Yale specific!! Modify as -;;; required.] -;;; ================================================================ - -;;; Announce your existence to the world at large. - -(provide 'haskell) - - -;;; Load these other files. - -(require 'comint) ; Olin Shivers' comint mode is the substratum - - - - -;;; ================================================================ -;;; Declare a bunch of variables. -;;; ================================================================ - - -;;; User settable (via M-x set-variable and M-x edit-options) - -(defvar haskell-program-name (getenv "HASKELLPROG") - "*Program invoked by the haskell command.") - -(defvar haskell-auto-create-process t - "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.") - -(defvar haskell-auto-switch-input t - "*If not nil, jump to *haskell* buffer automatically on input request.") - -(defvar haskell-ask-before-saving t - "*If not nil, ask before saving random haskell-mode buffers.") - -(defvar haskell-initial-printers '("interactive") - "*Printers to set when starting a new Haskell process.") - - -;;; Pad/buffer Initialization variables - -(defvar *haskell-buffer* "*haskell*" - "Name of the haskell process buffer") - -(defvar haskell-main-pad "\*Main-pad\*" - "Scratch pad associated with module Main") - -(defvar haskell-main-module "Main") - - -(defvar *last-loaded* nil) -(defvar *last-module* haskell-main-module) -(defvar *last-pad* haskell-main-pad) - - -;;; These are used for haskell-tutorial mode. - -(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs") -(defvar *ht-temp-buffer* nil) -(defvar *ht-file-buffer* "Haskell-Tutorial-Master") - - - -;;; ================================================================ -;;; Haskell editing mode stuff -;;; ================================================================ - -;;; Leave this place alone... -;;; The definitions below have been pared down to the bare -;;; minimum; they will be restored later. -;;; -;;; -Satish 2/5. - -;;; Keymap for Haskell mode -(defvar haskell-mode-map (make-sparse-keymap) - "Keymap used for haskell-mode") - -(defun haskell-establish-key-bindings (keymap) - (define-key keymap "\C-ce" 'haskell-eval) - (define-key keymap "\C-cr" 'haskell-run) - (define-key keymap "\C-ct" 'haskell-report-type) - (define-key keymap "\C-cm" 'haskell-run-main) - (define-key keymap "\C-c\C-r" 'haskell-run-file) - (define-key keymap "\C-cp" 'haskell-get-pad) - (define-key keymap "\C-c\C-o" 'haskell-optimizers) - (define-key keymap "\C-c\C-p" 'haskell-printers) - (define-key keymap "\C-cc" 'haskell-compile) - (define-key keymap "\C-cl" 'haskell-load) - (define-key keymap "\C-ch" 'haskell-switch) - (define-key keymap "\C-c\C-k" 'haskell-kill) - (define-key keymap "\C-c:" 'haskell-command) - (define-key keymap "\C-cq" 'haskell-exit) - (define-key keymap "\C-ci" 'haskell-interrupt) - (define-key keymap "\C-cu" 'haskell-edit-unit)) - - -(haskell-establish-key-bindings haskell-mode-map) - - -(defvar haskell-mode-syntax-table nil - "Syntax table used for haskell-mode") - -(if haskell-mode-syntax-table - nil - (setq haskell-mode-syntax-table (standard-syntax-table))) - -;;; Command for invoking the Haskell mode -(defun haskell-mode nil - "Major mode for editing Haskell code to run in Emacs -The following commands are available: -\\{haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks that are the value of variable -haskell-mode-hook. - -Windows: - -There are 3 types of windows associated with Haskell mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued . - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file buffer, then the cursor tells which module is the current - module and the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main in the current module. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. -" - (interactive) - (kill-all-local-variables) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-relative-maybe) - ;(setq local-abbrev-table haskell-mode-abbrev-table) - (set-syntax-table haskell-mode-syntax-table) - ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list?? - (run-hooks 'haskell-mode-hook)) - - - -;;;================================================================ -;;; Inferior Haskell stuff -;;;================================================================ - - -(defvar inferior-haskell-mode-map (full-copy-sparse-keymap comint-mode-map)) - -(haskell-establish-key-bindings inferior-haskell-mode-map) -(define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input) - -(defvar haskell-source-modes '(haskell-mode) - "*Used to determine if a buffer contains Haskell source code. -If it's loaded into a buffer that is in one of these major modes, -it's considered a Haskell source file.") - -(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" - "Regular expression capturing the Haskell system prompt.") - -(defvar haskell-prompt-ring () - "Keeps track of input to haskell process from the minibuffer") - -(defun inferior-haskell-mode-variables () - nil) - - -;;; INFERIOR-HASKELL-MODE (adapted from comint.el) - -(defun inferior-haskell-mode () - "Major mode for interacting with an inferior Haskell process. - -The following commands are available: -\\{inferior-haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks on comint-mode-hook and -inferior-haskell-mode-hook (in that order). - -You can send text to the inferior Haskell process from other buffers containing -Haskell source. - - -Windows: - -There are 3 types of windows in the inferior-haskell-mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued. - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file, then the cursor tells which module is the current module and - the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. - -The usual comint functions are also available. In particular, the -following are all available: - -comint-bol: Beginning of line, but skip prompt. Bound to C-a by default. -comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in - which case send EOF to process. Bound to C-d by default. - -Note however, that the default keymap bindings provided shadow some of -the default comint mode bindings, so that you may want to bind them -to your choice of keys. - -Comint mode's dynamic completion of filenames in the buffer is available. -(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.) - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - - (interactive) - (comint-mode) - (setq comint-prompt-regexp haskell-prompt-pattern) - ;; Customise in inferior-haskell-mode-hook - (inferior-haskell-mode-variables) - (setq major-mode 'inferior-haskell-mode) - (setq mode-name "Inferior Haskell") - (setq mode-line-process '(": %s : busy")) - (use-local-map inferior-haskell-mode-map) - (setq comint-input-filter 'haskell-input-filter) - (setq comint-input-sentinel 'ignore) - (setq comint-get-old-input 'haskell-get-old-input) - (run-hooks 'inferior-haskell-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq haskell-prompt-ring (make-ring input-ring-size))) - - -(defun haskell-input-filter (str) - "Don't save whitespace." - (not (string-match "\\s *" str))) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; This keeps track of the status of the haskell process. -;;; Values are: -;;; busy -- The process is busy. -;;; ready -- The process is ready for a command. -;;; input -- The process is waiting for input. -;;; debug -- The process is in the debugger. - -(defvar *haskell-status* 'busy - "Status of the haskell process") - -(defun set-haskell-status (value) - (setq *haskell-status* value) - (haskell-update-mode-line)) - -(defun get-haskell-status () - *haskell-status*) - -(defun haskell-update-mode-line () - (save-excursion - (set-buffer *haskell-buffer*) - (cond ((eq *haskell-status* 'ready) - (setq mode-line-process '(": %s: ready"))) - ((eq *haskell-status* 'input) - (setq mode-line-process '(": %s: input"))) - ((eq *haskell-status* 'busy) - (setq mode-line-process '(": %s: busy"))) - ((eq *haskell-status* 'debug) - (setq mode-line-process '(": %s: debug"))) - (t - (haskell-mode-error "Confused about status of haskell process!"))) - ;; Yes, this is the officially sanctioned technique for forcing - ;; a redisplay of the mode line. - (set-buffer-modified-p (buffer-modified-p)))) - - -(defun haskell-send-to-process (string) - (process-send-string "haskell" string) - (process-send-string "haskell" "\n")) - - - -;;; ================================================================== -;;; Handle input in haskell process buffer; history commands. -;;; ================================================================== - -(defun haskell-get-old-input () - "Get old input text from Haskell process buffer." - (save-excursion - (if (re-search-forward haskell-prompt-pattern (point-max) 'move) - (goto-char (match-beginning 0))) - (cond ((re-search-backward haskell-prompt-pattern (point-min) t) - (comint-skip-prompt) - (let ((temp (point))) - (end-of-line) - (buffer-substring temp (point))))))) - - -(defun haskell-send-input () - "Send input to Haskell while in the process buffer" - (interactive) - (if (eq (get-haskell-status) 'debug) - (comint-send-input) - (haskell-send-input-aux))) - -(defun haskell-send-input-aux () - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) - (haskell-mode-error "Current buffer has no process!") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (buffer-substring pmark (point)) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) - (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)) - (haskell-send-to-process input))))) - - - -;;; ================================================================== -;;; Minibuffer input stuff -;;; ================================================================== - -;;; Haskell input history retrieval commands (taken from comint.el) -;;; M-p -- previous input M-n -- next input - -(defvar haskell-minibuffer-local-map nil - "Local map for minibuffer when in Haskell") - -(if haskell-minibuffer-local-map - nil - (progn - (setq haskell-minibuffer-local-map - (full-copy-sparse-keymap minibuffer-local-map)) - ;; Haskell commands - (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input) - (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input) - )) - -(defun haskell-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length haskell-prompt-ring))) - (cond ((<= len 0) - (message "Empty input ring.") - (ding)) - (t - (cond ((eq last-command 'haskell-previous-input) - (delete-region (mark) (point)) - (set-mark (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (insert (ring-ref haskell-prompt-ring input-ring-index)) - (setq this-command 'haskell-previous-input)) - ))) - -(defun haskell-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (haskell-previous-input (- arg))) - -(defvar haskell-last-input-match "" - "Last string searched for by Haskell input history search, for defaulting. -Buffer local variable.") - -(defun haskell-previous-input-matching (str) - "Searches backwards through input history for substring match" - (interactive (let ((s (read-from-minibuffer - (format "Command substring (default %s): " - haskell-last-input-match)))) - (list (if (string= s "") haskell-last-input-match s)))) - (setq haskell-last-input-match str) ; update default - (let ((str (regexp-quote str)) - (len (ring-length haskell-prompt-ring)) - (n 0)) - (while (and (<= n len) - (not (string-match str (ring-ref haskell-prompt-ring n)))) - (setq n (+ n 1))) - (cond ((<= n len) (haskell-previous-input (+ n 1))) - (t (haskell-mode-error "Not found."))))) - - -;;; Actually read an expression from the minibuffer using the new keymap. - -(defun haskell-get-expression (prompt) - (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map))) - (ring-insert haskell-prompt-ring exp) - exp)) - - - -;;; ================================================================== -;;; Handle output from Haskell process -;;; ================================================================== - -;;; The haskell process produces output with embedded control codes. -;;; These control codes are used to keep track of what kind of input -;;; the haskell process is expecting. Ordinary output is just displayed. -;;; -;;; This is kind of complicated because control sequences can be broken -;;; across multiple batches of text received from the haskell process. -;;; If the string ends in the middle of a control sequence, save it up -;;; for the next call. - -(defvar *haskell-saved-output* nil) - -;;; On the Next, there is some kind of race condition that causes stuff -;;; sent to the Haskell subprocess before it has really started to be lost. -;;; The point of this variable is to force the Emacs side to wait until -;;; Haskell has started and printed out its banner before sending it -;;; anything. See start-haskell below. - -(defvar *haskell-process-alive* nil) - -(defun haskell-output-filter (process str) - "Filter for output from Yale Haskell command interface" - ;; *** debug - ;;(let ((buffer (get-buffer-create "haskell-output"))) - ;; (save-excursion - ;; (set-buffer buffer) - ;; (insert str))) - (setq *haskell-process-alive* t) - (let ((next 0) - (start 0) - (data (match-data))) - (unwind-protect - (progn - ;; If there was saved output from last time, glue it in front of the - ;; newly received input. - (if *haskell-saved-output* - (progn - (setq str (concat *haskell-saved-output* str)) - (setq *haskell-saved-output* nil))) - ;; Loop, looking for complete command sequences. - ;; Set next to point to the first one. - ;; start points to first character to be processed. - (while (setq next - (string-match *haskell-message-match-regexp* - str start)) - ;; Display any intervening ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next))) - ;; Now dispatch on the particular command sequence found. - ;; Handler functions are called with the string and start index - ;; as arguments, and should return the index of the "next" - ;; character. - (let ((end (match-end 0))) - (haskell-handle-message str next) - (setq start end))) - ;; Look to see whether the string ends with an incomplete - ;; command sequence. - ;; If so, save the tail of the string for next time. - (if (and (setq next - (string-match *haskell-message-prefix-regexp* str start)) - (eq (match-end 0) (length str))) - (setq *haskell-saved-output* (substring str next)) - (setq next (length str))) - ;; Display any leftover ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next)))) - (store-match-data data)))) - -(defvar *haskell-message-match-regexp* - "EMACS:.*\n") - -(defvar *haskell-message-prefix-regexp* - "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?") - -(defvar *haskell-message-dispatch* - '(("EMACS:debug\n" . haskell-got-debug) - ("EMACS:busy\n" . haskell-got-busy) - ("EMACS:input\n" . haskell-got-input) - ("EMACS:ready\n" . haskell-got-ready) - ("EMACS:printers .*\n" . haskell-got-printers) - ("EMACS:optimizers .*\n" . haskell-got-optimizers) - ("EMACS:message .*\n" . haskell-got-message) - ("EMACS:error\n" . haskell-got-error) - )) - -(defun haskell-handle-message (str idx) - (let ((list *haskell-message-dispatch*) - (fn nil)) - (while (and list (null fn)) - (if (eq (string-match (car (car list)) str idx) idx) - (setq fn (cdr (car list))) - (setq list (cdr list)))) - (if (null fn) - (haskell-mode-error "Garbled message from Haskell!") - (let ((end (match-end 0))) - (funcall fn str idx end) - end)))) - - -(defun haskell-message-data (string start end) - (let ((real-start (+ (string-match " " string start) 1)) - (real-end (- end 1))) - (substring string real-start real-end))) - -(defun haskell-got-debug (string start end) - (beep) - (message "In the debugger!") - (set-haskell-status 'debug)) - -(defun haskell-got-busy (string start end) - (set-haskell-status 'busy)) - -(defun haskell-got-input (string start end) - (if haskell-auto-switch-input - (progn - (haskell-switch) - (beep))) - (set-haskell-status 'input) - (message "Waiting for input...")) - -(defun haskell-got-ready (string start end) - (set-haskell-status 'ready)) - -(defun haskell-got-printers (string start end) - (haskell-printers-update (haskell-message-data string start end))) - -(defun haskell-got-optimizers (string start end) - (haskell-optimizers-update (haskell-message-data string start end))) - -(defun haskell-got-message (string start end) - (message "%s" (haskell-message-data string start end))) - -(defun haskell-got-error (string start end) - (beep) - (message "Haskell error.")) - - -;;; Displays output at end of given buffer. -;;; This function only ensures that the output is visible, without -;;; selecting the buffer in which it is displayed. -;;; Note that just using display-buffer instead of all this rigamarole -;;; won't work; you need to temporarily select the window containing -;;; the *haskell-buffer*, or else the display won't be scrolled to show -;;; the new output. -;;; *** This should really position the window in the buffer so that -;;; *** the point is on the last line of the window. - -(defun haskell-display-output (str) - (let ((window (selected-window))) - (unwind-protect - (progn - (pop-to-buffer *haskell-buffer*) - (haskell-display-output-aux str)) - (select-window window)))) - -(defun haskell-display-output-aux (str) - (haskell-move-marker) - (insert str) - (haskell-move-marker)) - - - -;;; ================================================================== -;;; Interactive commands -;;; ================================================================== - - -;;; HASKELL -;;; ------- -;;; -;;; This is the function that fires up the inferior haskell process. - -(defun haskell () - "Run an inferior Haskell process with input and output via buffer *haskell*. -Takes the program name from the variable haskell-program-name. -Runs the hooks from inferior-haskell-mode-hook -(after the comint-mode-hook is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive) - (if (not (haskell-process-exists-p)) - (start-haskell))) - -(defun start-haskell () - (message "Starting haskell subprocess...") - ;; Kill old haskell process. Normally this routine is only called - ;; after checking haskell-process-exists-p, but things can get - ;; screwed up if you rename the *haskell* buffer while leaving the - ;; old process running. This forces it to get rid of the old process - ;; and start a new one. - (if (get-process "haskell") - (delete-process "haskell")) - (let ((haskell-buffer - (apply 'make-comint - "haskell" - (or haskell-program-name - (haskell-mode-error "Haskell-program-name undefined!")) - nil - nil))) - (save-excursion - (set-buffer haskell-buffer) - (inferior-haskell-mode)) - (haskell-session-init) - ;; Wait for process to get started before sending it anything - ;; to avoid race condition on NeXT. - (setq *haskell-process-alive* nil) - (while (not *haskell-process-alive*) - (sleep-for 1)) - (haskell-send-to-process ":(use-emacs-interface)") - (haskell-printers-set haskell-initial-printers nil) - (display-buffer haskell-buffer)) - (message "Starting haskell subprocess... Done.")) - - -(defun haskell-process-exists-p () - (let ((haskell-buffer (get-buffer *haskell-buffer*))) - (and haskell-buffer (comint-check-proc haskell-buffer)))) - - - -;;; Initialize things on the emacs side, and tell haskell that it's -;;; talking to emacs. - -(defun haskell-session-init () - (set-haskell-status 'busy) - (setq *last-loaded* nil) - (setq *last-module* haskell-main-module) - (setq *last-pad* haskell-main-pad) - (setq *haskell-saved-output* nil) - (haskell-create-main-pad) - (set-process-filter (get-process "haskell") 'haskell-output-filter) - ) - - -(defun haskell-create-main-pad () - (let ((buffer (get-buffer-create haskell-main-pad))) - (save-excursion - (set-buffer buffer) - (haskell-mode)) - (haskell-record-pad-mapping - haskell-main-pad haskell-main-module nil) - buffer)) - - -;;; Called from evaluation and compilation commands to start up a Haskell -;;; process if none is already in progress. - -(defun haskell-maybe-create-process () - (cond ((haskell-process-exists-p) - t) - (haskell-auto-create-process - (start-haskell)) - (t - (haskell-mode-error "No Haskell process!")))) - - - -;;; HASKELL-GET-PAD -;;; ------------------------------------------------------------------ - -;;; This always puts the pad buffer in the "other" window. -;;; Having it wipe out the .hs file window is clearly the wrong -;;; behavior. - -(defun haskell-get-pad () - "Creates a new scratch pad for the current module. -Signals an error if the current buffer is not a .hs file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (do-get-pad fname (current-buffer)) - (haskell-mode-error "Not in a .hs buffer!")))) - - -(defun do-get-pad (fname buff) - (let* ((mname (or (haskell-get-modname buff) - (read-no-blanks-input "Scratch pad for module? " nil))) - (pname (haskell-lookup-pad mname fname)) - (pbuff nil)) - ;; Generate the base name of the pad buffer, then create the - ;; buffer. The actual name of the pad buffer may be something - ;; else because of name collisions. - (if (not pname) - (progn - (setq pname (format "*%s-pad*" mname)) - (setq pbuff (generate-new-buffer pname)) - (setq pname (buffer-name pbuff)) - (haskell-record-pad-mapping pname mname fname) - ) - (setq pbuff (get-buffer pname))) - ;; Make sure the pad buffer is in haskell mode. - (pop-to-buffer pbuff) - (haskell-mode))) - - - -;;; HASKELL-SWITCH -;;; ------------------------------------------------------------------ - -(defun haskell-switch () - "Switches to \*haskell\* buffer." - (interactive) - (haskell-maybe-create-process) - (pop-to-buffer *haskell-buffer*) - (push-mark) - (goto-char (point-max))) - - - -;;; HASKELL-KILL -;;; ------------------------------------------------------------------ - -(defun haskell-kill () - "Kill contents of *haskell* buffer. \\[haskell-kill]" - (interactive) - (save-excursion - (set-buffer *haskell-buffer*) - (beginning-of-buffer) - (let ((mark (point))) - (end-of-buffer) - (kill-region mark (point))))) - - - -;;; HASKELL-COMMAND -;;; ------------------------------------------------------------------ - -(defun haskell-command (str) - "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]" - (interactive "sHaskell command: ") - (haskell-send-to-process (format ":%s" str))) - - -;;; HASKELL-EVAL and HASKELL-RUN -;;; ------------------------------------------------------------------ - -(defun haskell-eval () - "Evaluate expression in current module. \\[haskell-eval]" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-eval")) - -(defun haskell-run () - "Run Haskell Dialogue in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ") - "emacs-run")) - -(defun haskell-run-main () - "Run Dialogue named main in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux "main" "emacs-run")) - -(defun haskell-report-type () - "Print the type of the expression." - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-report-type")) - -(defun haskell-eval-aux (exp fn) - (cond ((equal *haskell-buffer* (buffer-name)) - ;; In the *haskell* buffer. - (let* ((pname *last-pad*) - (mname *last-module*) - (fname *last-loaded*)) - (haskell-eval-aux-aux exp pname mname fname fn))) - ((buffer-file-name) - ;; In a .hs file. - (let* ((fname (buffer-file-name)) - (mname (haskell-get-modname (current-buffer))) - (pname (haskell-lookup-pad mname fname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - (t - ;; In a pad. - (let* ((pname (buffer-name (current-buffer))) - (mname (haskell-get-module-from-pad pname)) - (fname (haskell-get-file-from-pad pname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - )) - -(defun haskell-eval-aux-aux (exp pname mname fname fn) - (haskell-save-modified-source-files fname) - (haskell-send-to-process (format ":(%s" fn)) - (haskell-send-to-process - (prin1-to-string exp)) - (haskell-send-to-process - (prin1-to-string (or pname fname "interactive"))) - (haskell-send-to-process - (prin1-to-string - (if (and pname (get-buffer pname)) - (save-excursion - (set-buffer pname) - (buffer-string)) - ""))) - (haskell-send-to-process - (format "'|%s|" mname)) - (haskell-send-to-process - (if fname - (prin1-to-string (haskell-maybe-get-unit-file-name fname)) - "'#f")) - (haskell-send-to-process ")") - (setq *last-pad* pname) - (setq *last-module* mname) - (setq *last-loaded* fname)) - - - -;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE -;;; ------------------------------------------------------------------ - -(defun haskell-run-file () - "Runs Dialogue named main in current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-run-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-load () - "Load current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-load-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-compile () - "Compile current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-compile-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - - -(defun haskell-get-file-to-operate-on () - (cond ((equal *haskell-buffer* (buffer-name)) - ;; When called from the haskell process buffer, prompt for a file. - (call-interactively 'haskell-get-file/prompt)) - ((buffer-file-name) - ;; When called from a .hs file buffer, use the unit file - ;; associated with it, if there is one. - (haskell-maybe-get-unit-file-name (buffer-file-name))) - (t - ;; When called from a pad, use the file that the module the - ;; pad belongs to lives in. - (haskell-maybe-get-unit-file-name - (haskell-get-file-from-pad (buffer-name (current-buffer))))))) - -(defun haskell-get-file/prompt (filename) - (interactive "fHaskell file: ") - (haskell-run-file-aux filename)) - - - -;;; HASKELL-EXIT -;;; ------------------------------------------------------------------ - -(defun haskell-exit () - "Quit the haskell process." - (interactive) - (cond ((not (haskell-process-exists-p)) - (message "No process currently running.")) - ((y-or-n-p "Do you really want to quit Haskell? ") - (haskell-send-to-process ":quit") - ;; If we were running the tutorial, mark the temp buffer as unmodified - ;; so we don't get asked about saving it later. - (if (and *ht-temp-buffer* - (get-buffer *ht-temp-buffer*)) - (save-excursion - (set-buffer *ht-temp-buffer*) - (set-buffer-modified-p nil))) - ;; Try to remove the haskell output buffer from the screen. - (bury-buffer *haskell-buffer*) - (replace-buffer-in-windows *haskell-buffer*)) - (t - nil))) - - -;;; HASKELL-INTERRUPT -;;; ------------------------------------------------------------------ - -(defun haskell-interrupt () - "Interrupt the haskell process." - (interactive) - (if (haskell-process-exists-p) - (haskell-send-to-process "\C-c"))) - - - -;;; HASKELL-EDIT-UNIT -;;; ------------------------------------------------------------------ - -(defun haskell-edit-unit () - "Edit the .hu file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (let ((find-file-not-found-hooks (list 'haskell-new-unit)) - (file-not-found nil) - (units-fname (haskell-get-unit-file-name fname))) - (find-file-other-window units-fname) - ;; If creating a new file, initialize it to contain the name - ;; of the haskell source file. - (if file-not-found - (save-excursion - (insert - (if (string= (file-name-directory fname) - (file-name-directory units-fname)) - (file-name-nondirectory fname) - fname) - "\n")))) - (haskell-mode-error "Not in a .hs buffer!")))) - -(defun haskell-new-unit () - (setq file-not-found t)) - - -;;; Look for a comment like "-- unit:" at top of file. -;;; If not found, assume unit file has same name as the buffer but -;;; a .hu extension. - -(defun haskell-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (concat (haskell-strip-file-extension fname) ".hu"))) - -(defun haskell-maybe-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (haskell-strip-file-extension fname))) - -(defun haskell-get-unit-file-name-from-file (fname) - (let ((buffer (get-file-buffer fname))) - (if buffer - (save-excursion - (beginning-of-buffer) - (if (re-search-forward "-- unit:[ \t]*" (point-max) t) - (let ((beg (match-end 0))) - (end-of-line) - (buffer-substring beg (point))) - nil)) - nil))) - - - - -;;; ================================================================== -;;; Support for printers/optimizers menus -;;; ================================================================== - -;;; This code was adapted from the standard buff-menu.el code. - -(defvar haskell-menu-mode-map nil "") - -(if (not haskell-menu-mode-map) - (progn - (setq haskell-menu-mode-map (make-keymap)) - (suppress-keymap haskell-menu-mode-map t) - (define-key haskell-menu-mode-map "m" 'hm-mark) - (define-key haskell-menu-mode-map "u" 'hm-unmark) - (define-key haskell-menu-mode-map "x" 'hm-exit) - (define-key haskell-menu-mode-map "q" 'hm-exit) - (define-key haskell-menu-mode-map " " 'next-line) - (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark) - (define-key haskell-menu-mode-map "?" 'describe-mode))) - -;; Printers Menu mode is suitable only for specially formatted data. - -(put 'haskell-menu-mode 'mode-class 'special) - -(defun haskell-menu-mode () - "Major mode for editing Haskell flags. -Each line describes a flag. -Letters do not insert themselves; instead, they are commands. -m -- mark flag (turn it on) -u -- unmark flag (turn it off) -x -- exit; tell the Haskell process to update the flags, then leave menu. -q -- exit; same as x. -Precisely,\\{haskell-menu-mode-map}" - (kill-all-local-variables) - (use-local-map haskell-menu-mode-map) - (setq truncate-lines t) - (setq buffer-read-only t) - (setq major-mode 'haskell-menu-mode) - (setq mode-name "Haskell Flags Menu") - ;; These are all initialized elsewhere - (make-local-variable 'hm-current-flags) - (make-local-variable 'hm-request-fn) - (make-local-variable 'hm-update-fn) - (run-hooks 'haskell-menu-mode-hook)) - - -(defun haskell-menu (help-file buffer request-fn update-fn) - (haskell-maybe-create-process) - (if (get-buffer buffer) - (progn - (pop-to-buffer buffer) - (goto-char (point-min))) - (progn - (pop-to-buffer buffer) - (insert-file-contents help-file) - (haskell-menu-mode) - (setq hm-request-fn request-fn) - (setq hm-update-fn update-fn) - )) - (hm-mark-current) - (message "m = mark; u = unmark; x = execute; q = quit; ? = more help.")) - - - -;;; A line that starts with *hm-marked* is a menu item turned on. -;;; A line that starts with *hm-unmarked* is turned off. -;;; A line that starts with anything else is just random text and is -;;; ignored by commands that deal with menu items. - -(defvar *hm-marked* " on") -(defvar *hm-unmarked* " ") -(defvar *hm-marked-regexp* " on \\w") -(defvar *hm-unmarked-regexp* " \\w") - -(defun hm-mark () - "Mark flag to be turned on." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-marked-regexp*) - (forward-line 1)) - ((looking-at *hm-unmarked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-unmarked*)) - (insert *hm-marked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-unmark () - "Unmark flag." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-unmarked-regexp*) - (forward-line 1)) - ((looking-at *hm-marked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-marked*)) - (insert *hm-unmarked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-backup-unmark () - "Move up and unmark." - (interactive) - (forward-line -1) - (hm-unmark) - (forward-line -1)) - - -;;; Actually make the changes. - -(defun hm-exit () - "Update flags, then leave menu." - (interactive) - (hm-execute) - (hm-quit)) - -(defun hm-execute () - "Tell haskell process to tweak flags." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((flags-on nil) - (flags-off nil)) - (while (not (eq (point) (point-max))) - (cond ((looking-at *hm-unmarked-regexp*) - (setq flags-off (cons (hm-flag) flags-off))) - ((looking-at *hm-marked-regexp*) - (setq flags-on (cons (hm-flag) flags-on))) - (t - nil)) - (forward-line 1)) - (funcall hm-update-fn flags-on flags-off)))) - - -(defun hm-quit () - (interactive) - "Make the menu go away." - (bury-buffer (current-buffer)) - (replace-buffer-in-windows (current-buffer))) - -(defun hm-flag () - (save-excursion - (beginning-of-line) - (forward-char 6) - (let ((beg (point))) - ;; End of flag name marked by tab or two spaces. - (re-search-forward "\t\\| ") - (buffer-substring beg (match-beginning 0))))) - - -;;; Update the menu to mark only those items currently turned on. - -(defun hm-mark-current () - (funcall hm-request-fn) - (save-excursion - (goto-char (point-min)) - (while (not (eq (point) (point-max))) - (cond ((and (looking-at *hm-unmarked-regexp*) - (hm-item-currently-on-p (hm-flag))) - (hm-mark)) - ((and (looking-at *hm-marked-regexp*) - (not (hm-item-currently-on-p (hm-flag)))) - (hm-unmark)) - (t - (forward-line 1)))))) - - -;;; See if a menu item is turned on. - -(defun hm-item-currently-on-p (item) - (member-string= item hm-current-flags)) - -(defun member-string= (item list) - (cond ((null list) - nil) - ((string= item (car list)) - list) - (t - (member-string= item (cdr list))))) - - - -;;; Make the menu for printers. - -(defvar *haskell-printers-help* - (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") - "Help file for printers.") - -(defvar *haskell-printers-buffer* "*Haskell printers*") - -(defun haskell-printers () - "Set printers interactively." - (interactive) - (haskell-menu - *haskell-printers-help* - *haskell-printers-buffer* - 'haskell-printers-inquire - 'haskell-printers-set)) - -(defun haskell-printers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-printers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-printers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-printers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-printers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - -;;; Equivalent stuff for the optimizers menu - -(defvar *haskell-optimizers-help* - (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") - "Help file for optimizers.") - -(defvar *haskell-optimizers-buffer* "*Haskell optimizers*") - -(defun haskell-optimizers () - "Set optimizers interactively." - (interactive) - (haskell-menu - *haskell-optimizers-help* - *haskell-optimizers-buffer* - 'haskell-optimizers-inquire - 'haskell-optimizers-set)) - -(defun haskell-optimizers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-optimizers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-optimizers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-optimizers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-optimizers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; Keep track of the association between pads, modules, and files. -;;; The global variable is a list of (pad-buffer-name module-name file-name) -;;; lists. - -(defvar *haskell-pad-mappings* () - "Associates pads with their corresponding module and file.") - -(defun haskell-record-pad-mapping (pname mname fname) - (setq *haskell-pad-mappings* - (cons (list pname mname fname) *haskell-pad-mappings*))) - -(defun haskell-get-module-from-pad (pname) - (car (cdr (assoc pname *haskell-pad-mappings*)))) - -(defun haskell-get-file-from-pad (pname) - (car (cdr (cdr (assoc pname *haskell-pad-mappings*))))) - -(defun haskell-lookup-pad (mname fname) - (let ((pname (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*))) - (if (and pname (get-buffer pname)) - pname - nil))) - -(defun haskell-lookup-pad-aux (mname fname list) - (cond ((null list) - nil) - ((and (equal mname (car (cdr (car list)))) - (equal fname (car (cdr (cdr (car list)))))) - (car (car list))) - (t - (haskell-lookup-pad-aux mname fname (cdr list))))) - - - -;;; Save any modified .hs and .hu files. -;;; Yes, the two set-buffer calls really seem to be necessary. It seems -;;; that y-or-n-p makes emacs forget we had temporarily selected some -;;; other buffer, and if you just do save-buffer directly it will end -;;; up trying to save the current buffer instead. The built-in -;;; save-some-buffers function has this problem.... - -(defun haskell-save-modified-source-files (filename) - (let ((buffers (buffer-list)) - (found-any nil)) - (while buffers - (let ((buffer (car buffers))) - (if (and (buffer-modified-p buffer) - (save-excursion - (set-buffer buffer) - (and buffer-file-name - (haskell-source-file-p buffer-file-name) - (setq found-any t) - (or (null haskell-ask-before-saving) - (and filename (string= buffer-file-name filename)) - (y-or-n-p - (format "Save file %s? " buffer-file-name)))))) - (save-excursion - (set-buffer buffer) - (save-buffer)))) - (setq buffers (cdr buffers))) - (if found-any - (message "") - (message "(No files need saving)")))) - -(defun haskell-source-file-p (filename) - (or (string-match "\\.hs$" filename) - (string-match "\\.lhs$" filename) - (string-match "\\.hi$" filename) - (string-match "\\.hu$" filename))) - - - -;;; Buffer utilities - -(defun haskell-move-marker () - "Moves the marker and point to the end of buffer" - (set-marker comint-last-input-end (point-max)) - (set-marker (process-mark (get-process "haskell")) (point-max)) - (goto-char (point-max))) - - - -;;; Extract the name of the module the point is in, from the given buffer. - -(defvar *haskell-re-module-hs* "^module\\s *") -(defvar *haskell-re-module-lhs* "^>\\s *module\\s *") -(defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*") - -(defun haskell-get-modname (buff) - "Get module name in BUFFER that point is in." - (save-excursion - (set-buffer buff) - (let ((regexp (if (haskell-lhs-filename-p (buffer-file-name)) - *haskell-re-module-lhs* - *haskell-re-module-hs*))) - (if (or (looking-at regexp) - (re-search-backward regexp (point-min) t) - (re-search-forward regexp (point-max) t)) - (progn - (goto-char (match-end 0)) - (if (looking-at *haskell-re-modname*) - (buffer-substring (match-beginning 0) (match-end 0)) - (haskell-mode-error "Module name not found!!"))) - "Main")))) - - -;;; Strip file extensions. -;;; Only strip off extensions we know about; e.g. -;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar". - -(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$") - -(defun haskell-strip-file-extension (filename) - "Strip off the extension from a filename." - (if (string-match *haskell-filename-regexp* filename) - (substring filename (match-beginning 1) (match-end 1)) - filename)) - - -;;; Is this a .lhs filename? - -(defun haskell-lhs-filename-p (filename) - (string-match ".*\\.lhs$" filename)) - - -;;; Haskell mode error - -(defun haskell-mode-error (msg) - "Show MSG in message line as an error from the haskell mode." - (error (concat "Haskell mode: " msg))) - - - -;;; ================================================================== -;;; User customization -;;; ================================================================== - -(defvar haskell-load-hook nil - "This hook is run when haskell is loaded in. -This is a good place to put key bindings." - ) - -(run-hooks 'haskell-load-hook) - - - - -;;;====================================================================== -;;; Tutorial mode setup -;;;====================================================================== - -;;; Set up additional key bindings for tutorial mode. - -(defvar ht-mode-map (make-sparse-keymap)) - -(haskell-establish-key-bindings ht-mode-map) -(define-key ht-mode-map "\C-c\C-f" 'ht-next-page) -(define-key ht-mode-map "\C-c\C-b" 'ht-prev-page) -(define-key ht-mode-map "\C-c\C-l" 'ht-restore-page) -(define-key ht-mode-map "\C-c?" 'describe-mode) - -(defun haskell-tutorial-mode () - "Major mode for running the Haskell tutorial. -You can use these commands: -\\{ht-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map ht-mode-map) - (setq major-mode 'haskell-tutorial-mode) - (setq mode-name "Haskell Tutorial") - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - - -(defun haskell-tutorial () - "Run the haskell tutorial." - (interactive) - (ht-load-tutorial) - (ht-make-buffer) - (ht-display-page) - (haskell-maybe-create-process) - (haskell-send-to-process ":(emacs-set-printers '(interactive))") - ) - - -;;; Load the tutorial file into a read-only buffer. Do not display this -;;; buffer. - -(defun ht-load-tutorial () - (let ((buffer (get-buffer *ht-file-buffer*))) - (if buffer - (save-excursion - (set-buffer buffer) - (beginning-of-buffer)) - (save-excursion - (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*))) - (let ((fname (substitute-in-file-name *ht-source-file*))) - (if (file-readable-p fname) - (ht-load-tutorial-aux fname) - (call-interactively 'ht-load-tutorial-aux))))))) - -(defun ht-load-tutorial-aux (filename) - (interactive "fTutorial file: ") - (insert-file filename) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (beginning-of-buffer)) - - -;;; Create a buffer to use for messing about with each page of the tutorial. -;;; Put the buffer into haskell-tutorial-mode. - -(defun ht-make-buffer () - (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs")) - (setq *ht-temp-buffer* (buffer-name)) - (haskell-tutorial-mode)) - - -;;; Commands for loading text into the tutorial pad buffer - -(defun ht-next-page () - "Go to the next tutorial page." - (interactive) - (if (ht-goto-next-page) - (ht-display-page) - (beep))) - -(defun ht-goto-next-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-forward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-prev-page () - "Go to the previous tutorial page." - (interactive) - (if (ht-goto-prev-page) - (ht-display-page) - (beep))) - -(defun ht-goto-prev-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-backward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-goto-page (arg) - "Go to the tutorial page specified as the argument." - (interactive "sGo to page: ") - (if (ht-searchfor-page (format "Page: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-goto-section (arg) - "Go to the tutorial section specified as the argument." - (interactive "sGo to section: ") - (if (ht-searchfor-page (format "Section: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-searchfor-page (search-string) - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (let ((point (point))) - (beginning-of-buffer) - (if (search-forward search-string nil t) - t - (progn - (goto-char point) - nil)))) - (set-buffer buff)))) - -(defun ht-restore-page () - (interactive) - (let ((old-point (point))) - (ht-display-page) - (goto-char old-point))) - -(defun ht-display-page () - (set-buffer *ht-file-buffer*) - (let* ((beg (progn - (if (search-backward "\C-l" nil t) - (forward-line 1) - (beginning-of-buffer)) - (point))) - (end (progn - (if (search-forward "\C-l" nil t) - (beginning-of-line) - (end-of-buffer)) - (point))) - (text (buffer-substring beg end))) - (set-buffer *ht-temp-buffer*) - (erase-buffer) - (insert text) - (beginning-of-buffer))) - - - -;;;====================================================================== -;;; Menu bar stuff -;;;====================================================================== - -;;; This only works in Emacs version 19, so it's in a separate file for now. - -(if (featurep 'menu-bar) - (load-library "haskell-menu")) diff --git a/ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt b/ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt deleted file mode 100644 index c18ac5db61..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt +++ /dev/null @@ -1,6 +0,0 @@ -Optimizer switches - inline Aggressively inline functions - constant Hoist constant expressions to top-level - foldr Perform foldr/build deforestation - lisp Tell the Lisp compiler to work hard to produce best code - delays Try to make delays out-of-line for more compact code diff --git a/ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt b/ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt deleted file mode 100644 index f8a620056e..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt +++ /dev/null @@ -1,26 +0,0 @@ -General messages - compiling Printed when the compilation system starts a compilation - loading Printed when a previously compiled unit is loaded - reading Prints the name of the file being parsed - pad Enables printing within scratch pads - interactive Print verbose messages in command loop - prompt Print prompt in command loop -Timings - time Prints the time that it takes to execute a computation - phase-time Prints the time of each phase of compilation -Compiler passes - parse Prints the program recreated from ast - import Lists all symbols imported and exported for each module - scope Print the program after scoping and precedence parsing - depend Prints entire program in nested let's - type Prints signatures during inference - cfn Prints entire program after context free normalization - depend2 Like depend - flic Prints entire program as flic code - optimize Prints entire program as optimized flic code - optimize-extra Prints extra verbose information during optimization - strictness Print strictness of all functions and variables - codegen Prints generated Lisp code - codegen-flic Prints generated Lisp code and associated flic code - dumper Prints the code in the interface - dump-stat Prints statistics for the interface file diff --git a/ghc/CONTRIB/haskell_poem b/ghc/CONTRIB/haskell_poem deleted file mode 100644 index 1f8218648a..0000000000 --- a/ghc/CONTRIB/haskell_poem +++ /dev/null @@ -1,58 +0,0 @@ -From: dsmith@lucy.cs.waikato.ac.nz -Subject: A Haskell Lover's Plea -Date: Thu, 16 Mar 1995 21:06:35 -0500 -To: haskell-dist@dcs.gla.ac.uk - - - A Haskell Lover's Plea - -Why should I renounce for you, dear Haskell, -My much yearned for side-effects? -Why should I face the software dragons -Without my weapon, my manly spear of destruction? -They call you non-strict, oh so elegant and pure Ariel. -Yet side-effect celibacy is surely severe. - - Your flesh is too weak, you brutish beast. - The tarpit demons of software hell await you! - This sinful habit in which you indulge - Does more harm than good. - Restrain yourself! And you too will see - The wondrous and refined joys of referential transparency! - -Alas, I can do without goto, without call/cc. -But sans side-effects, I am lost and forlorn, can't you see? -Oh, lady fairer yet than admirable Miranda (tm), -Scheme's prolix, parenthetical tedium -Is no match for your elegant syntax. What's more, -Your list comprehensions outshine even Prolog for sure... - - Ah, flatter me not, you low-spirited Caliban! - Do you not know what advantages await - Those who renounce destructive update? - Start with an immaculate high-level specification, - Throw in some algebraic code transformation. - Soon you will have a provably correct and maintainable implementation. - -Show mercy on mere mortals like me! -How I dream still of the efficient pleasures of pointer manipulation! -How I too wish to mutate memory with thoughts born of von Neumann earthiness! -Relent! Relent! Let me have my assignment, my printf, my gensym. -Let me fulfill my destructive impulses. -Let me set bang. Let me update. Let me assign. Let me mutate. - - Fear not, lowly beast, I have heard your pleas. - To satisfy your low-level desire - I'll give you monads, linear types, MADTs, - Even single-threaded polymorphic lambda calculi. - My beauty may suffer, still I will aspire - To let you do (within typeful limits) what you please. - -Rejoice! Rejoice! I'm free! I'm free! -The best of both worlds is mine at last. -Oh, infinite progeny of Church, Hope, and ML, -I curry favor not when I say: -Scan me right, fold me left, -Lazy lady of many shapes, you've got class. - - Don Smith (dsmith@cs.waikato.ac.nz) diff --git a/ghc/CONTRIB/mira2hs b/ghc/CONTRIB/mira2hs deleted file mode 100644 index 1ad61040f7..0000000000 --- a/ghc/CONTRIB/mira2hs +++ /dev/null @@ -1,364 +0,0 @@ -#!/bin/sh - -# mira2hs - Convert Miranda to Haskell (or Gofer) - -# usage: mira2hs [infile [outfile]] -# -# Input defaults to stdin, output defaults to <infile>.hs or stdout if -# input is stdin - -# Copyright Denis Howe 1992 -# -# Permission is granted to make and distribute verbatim or modified -# copies of this program, provided that every such copy or derived -# work carries the above copyright notice and is distributed under -# terms identical to these. -# -# Miranda is a trademark of Research Software Limited. -# (E-mail: mira-request@ukc.ac.uk). -# -# Denis Howe <dbh@doc.ic.ac.uk> - -# NOTE: This program needs a sed which understands \<word\> regular -# expressions, eg. Sun or GNU sed (gsed). - -# partain: got it from wombat.doc.ic.ac.uk:pub - -# 1.05 18 Sep 1992 zip -> zipPair -# 1.04 29 Jul 1992 Improve handling of ==, -- and whitespace round guards -# $infix -> `infix` -# 1.03 24 Apr 1992 Incorporate Lennart's miranda.hs functions -# Replace most Miranda fns & operators -# Use \<word\> patterns, ';' -> ',' in list comprehension -# Provide example main functions -# 1.02 30 Mar 1992 Mods to header, fix handling of type,type -# Comment out String definition, Bool ops -# num -> Int, = -> == in guards -# 1.01 10 Dec 1991 Convert type names to initial capital -# 1.00 27 Sep 1991 Initial version advertised to net - -# Does NOT handle: -# continued inequalities (a < x < b) -# boolean '=' operator -> '==' (except in guards) -# main function -# multi-line type definitions -# guards on different line from body -# diagonalised list comprehensions (//) -# repeated variables in patterns (eg. LHS of function) -# filemode -> statusFile, getenv -> getEnv, read -> readFile, system -# include directives -# conflicts with prelude identifiers - -# Miranda's num type (Integral+Floating) is changed to Int so won't -# work for non-intger nums. Miranda has irrefutable ("lazy") tuple -# patterns so you may need to add a ~, like ~(x,y) in Haskell. -# Haskell functions "length" and "not" may need parentheses round -# their arguments. - -# mira2hs copes equally well with literate and illiterate scripts. It -# doesn't care what characters lines begins with - it assumes -# everything is code. It will convert code even inside comments. -# -# For literate programs you will have to turn the standard header into -# literate form and rename the output .lhs. You might want to do this -# to (a copy of) mira2hs itself if you have lots of literate progs. - -# ToDo: = inside brackets -> == - -if [ -n "$1" ] -then in=$1 - out=`basename $in .m`.hs -else in="Standard input" -fi -[ -n "$2" ] && out=$2 -tmp=/tmp/m2h$$ -script=${tmp}s - -# Prepend a standard header and some function definitions. -echo -- $in converted to Haskell by $USER on `date` > $tmp -cat << "++++" >> $tmp -module Main (main) where - --------------------- mira2hs functions -------------------- - -cjustify :: Int -> String -> String -cjustify n s = spaces l ++ s ++ spaces r - where - m = n - length s - l = div m 2 - r = m - l - -e :: (Floating a) => a -e = exp 1 - -hugenum :: (RealFloat a) => a -hugenum = encodeFloat (r^d-1) (n-d) - where r = floatRadix hugenum - d = floatDigits hugenum - (_,n) = floatRange hugenum - -subscripts :: [a] -> [Int] -- Miranda index -subscripts xs = f xs 0 - where f [] n = [] - f (_:xs) n = n : f xs (n+1) - -integer :: (RealFrac a) => a -> Bool -integer x = x == fromIntegral (truncate x) - -lay :: [String] -> String -lay = concat . map (++"\n") - -layn :: [String] -> String -layn = concat . zipWith f [1..] - where - f :: Int -> String -> String - f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n" - -limit :: (Eq a) => [a] -> a -limit (x:y:ys) | x == y = x - | otherwise = limit (y:ys) -limit _ = error "limit: bad use" - -ljustify :: Int -> String -> String -ljustify n s = s ++ spaces (n - length s) - -member :: (Eq a) => [a] -> a -> Bool -member xs x = elem x xs - -merge :: (Ord a) => [a] -> [a] -> [a] -merge [] ys = ys -merge xs [] = xs -merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys - | otherwise = y : merge xxs ys - -numval :: (Num a) => String -> a -numval cs = read cs - -postfix :: [a] -> a -> [a] -postfix xs x = xs ++ [x] - -rep :: Int -> b -> [b] -rep n x = take n (repeat x) - -rjustify :: Int -> String -> String -rjustify n s = spaces (n - length s) ++ s - -seq :: (Eq a) => a -> b -> b -seq x y = if x == x then y else y - -shownum :: (Num a) => a -> String -shownum x = show x - -sort :: (Ord a) => [a] -> [a] -sort x | n <= 1 = x - | otherwise = merge (sort (take n2 x)) (sort (drop n2 x)) - where n = length x - n2 = div n 2 -spaces :: Int -> String -spaces 0 = "" -spaces n = ' ' : spaces (n-1) - -tinynum :: (RealFloat a) => a -tinynum = encodeFloat 1 (n-d) - where r = floatRadix tinynum - d = floatDigits tinynum - (n,_) = floatRange tinynum - -undef :: a -undef = error "undefined" - -zipPair (x,y) = zip x y - --- Following is UNTESTED -data Sys_message = - Stdout String | Stderr String | Tofile String String | - Closefile String | Appendfile String | --- System String | - Exit Int - -doSysMessages :: [Sys_message] -> Dialogue -doSysMessages requests responses = doMsgs requests [] - -doMsgs [] afs = [] -doMsgs ((Appendfile f):rs) afs = doMsgs rs (f:afs) -doMsgs ((Exit n) :rs) afs = [] -doMsgs (r :rs) afs - = doMsg r : doMsgs rs afs - where doMsg (Stdout s) = AppendChan stdout s - doMsg (Stderr s) = AppendChan stderr s - doMsg (Tofile f s) | elem f afs = AppendFile f s - | otherwise = WriteFile f s - doMsg (Closefile f) - = error "doSysMessages{mira2hs}: Closefile sys_message not supported" --- doMsg (Closefile f) = CloseFile f -- optional --- doMsg (System cmd) --- = error "doSysMessages{mira2hs}: System sys_message not supported" - --- Pick a main. (If I was clever main would be an overloaded fn :-). -main :: Dialogue --- main = printString s -- s :: String --- main = interact f -- f :: String -> String --- main = doSysMessages l -- l :: [Sys_message] --- main = print x -- x :: (Text a) => a - -printString :: String -> Dialogue -printString s = appendChan stdout s abort done - --------------------- mira2hs functions end -------------------- - -++++ -# It's amazing what sed can do. -sed ' -# Type synonyms and constructed types: insert "type" or "data". Add a -# dummy :: to flag this line to the type name munging below. Beware -# ====== in comments. -/[^=]==[^=]/s/\(.*=\)=/::type \1/g -/::=/s/\(.*\)::=/::data \1=/g -# Change type variable *s to "a"s -/::/s/\*/a/g -# List length & various other renamed functions (# reused below). -s/ *# */ length /g -s/\<arctan\>/atan/g -s/\<code\>/ord/g -s/\<converse\>/flip/g -s/\<decode\>/chr/g -s/\<dropwhile\>/dropWhile/g -s/\<digit\>/isDigit/g -s/\<entier\>/floor/g -s/\<hd\>/head/g -s/\<index\>/subscripts/g -s/\<letter\>/isAlpha/g -s/\<map2\>/zipWith/g -s/\<max\>/maximum/g -s/\<max2\>/max/g -s/\<min\>/minimum/g -s/\<min2\>/min/g -s/\<mkset\>/nub/g -s/\<neg\>/negate/g -s/\<scan\>/scanl/g -s/\<tl\>/tail/g -# Miranda uncurried zip -> zipPair (above). Do before zip2->zip. -s/\<zip\>/zipPair/g -# Miranda curried zip2 -> zip -s/\<zip2\>/zip/g -# Haskel div and mod are functions, not operators -s/\<div\>/\`div\`/g -s/\<mod\>/\`mod\`/g -# Locate commas introducing guards by temporarily changing others. -# Replace comma with # when after || or unmatched ( or [ or before -# unmatched ) or ] or in string or char constants. Replace -# matched () not containing commas with _<_ _>_ and matched [] -# with _{_ _}_ and repeat until no substitutions. -: comma -s/\(||.*\),/\1#/g -s/\([[(][^])]*\),/\1#/g -s/,\([^[(]*[])]\)/#\1/g -s/(\([^),]*\))/_<_\1_>_/g -s/\[\([^],]*\)\]/_{_\1_}_/g -s/"\(.*\),\(.*\)"/"\1#\2"/g -'"#change quotes -s/','/'#'/g -"'#change quotes -t comma -# Restore () and [] -s/_<_/(/g -s/_>_/)/g -s/_{_/[/g -s/_}_/]/g -# The only commas left now introduce guards, remove optional "if" -s/,[ ]*if/,/g -s/[ ]*,[ ]*/,/g -# Temporarily change ~=, <=, >=. -s%~=%/_eq_%g -s/<=/<_eq_/g -s/>=/>_eq_/g -# Replace every = in guard with == (do after type synonyms) -: neq -s/\(,.*[^=]\)=\([^=]\)/\1==\2/ -t neq -# Fix other equals -s/_eq_/=/g -# Replace <pattern> = <rhs> , <guard> with <pattern> | (<guard>) = <rhs> -s/=\(..*\),\(..*\)/| (\2) =\1/g -s/(otherwise)/otherwise/g -# Restore other commas -s/#/,/g -# List difference. Beware ------ in comments. -s/\([^-]\)--\([^-]\)/\1\\\\\2/g -# Comments (do after list diff) -s/||/--/g -s/--|/---/g -# Boolean not, or, and (do after comments) -s/ *~ */ not /g -s% *\\/ *% || %g -s/&/&&/g -# list indexing -s/!/!!/g -# Locate semicolon in list comprehensions by temporarily replacing ones -# in string or char constants with #. Replace matched [] not -# containing semicolon with _{_ _}_ and repeat until no substitutions. -: semico -s/\[\([^];]*\)\]/_{_\1_}_/g -s/"\([^;"]*\);\([^;"]*\)"/"\1#\2"/g -'"#change quotes -s/';'/'#'/g -"'# change quotes -t semico -# Remaining [ ] must contain semicolons which we change to comas. -: lcomp -s/\(\[[^;]*\);/\1,/g -s/;\([^;]*\]\)/,\1/g -t lcomp -# Restore [] and other semicolons -s/_{_/[/g -s/_}_/]/g -s/#/;/g -# Miranda dollar turns a function into an infix operator -s/\$\([_A-Za-z0-9'\'']\{1,\}\)/`\1`/g -' $1 >> $tmp - -# Create a sed script to change the first letter of each type name to -# upper case. -# Dummy definitions for predefined types (num is special). -( - echo ::type char = - echo ::type bool = - echo ::type sys_message = - cat $tmp -) | \ -# Find type definitions & extract type names -sed -n '/::data[ ].*=/{ -h;s/::data[ ]*\([^ =]\).*/\1/p -y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p -g;s/::data[ ]*[^ =]\([^ =]*\).*=.*/\1/p -} -/::type[ ].*=/{ -h;s/::type[ ]*\([^ =]\).*/\1/p -y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p -g;s/::type[ ]*[^ =]\([^ =]*\).*=.*/\1/p -}' | \ -# Read lower case initial, upper case inital and rest of type name. -# Type is always after "::". -( -echo ": loop" -while read h; read H; read t -do echo "/::/s/\<$h$t\>/$H$t/g" -done -cat << "++++" -# num -> Int -/::/s/\<num\>/Int/g -# Loop round to catch type,type,.. -t loop -# Remove the dummy :: flags from type definitions. -s/::type/type/ -s/::data/data/ -# Comment out string type if defined. -s/\(type[ ]*String[ ]*=\)/-- \1/ -++++ -) > $script - -if [ "$out" ] -then exec > $out -fi -sed -f $script $tmp -rm -f ${tmp}* diff --git a/ghc/CONTRIB/pphs/Jmakefile b/ghc/CONTRIB/pphs/Jmakefile deleted file mode 100644 index 24d546c7e7..0000000000 --- a/ghc/CONTRIB/pphs/Jmakefile +++ /dev/null @@ -1,16 +0,0 @@ -SuffixRule_c_o() - -BuildPgmFromOneCFile(pphs) - -InstallBinaryTarget(pphs,$(INSTBINDIR_GHC)) - -/* These .dvi-ish rules are not right, but so what? [WDP 94/09] */ - -docs/UserGuide.dvi: docs/UserGuide.tex - $(RM) $@ - (cd docs && ../$(LTX) UserGuide.tex) - -/* Student project final report */ -docs/Report.dvi: docs/Report.tex - $(RM) $@ - (cd docs && ../$(LTX) Report.tex) diff --git a/ghc/CONTRIB/pphs/README b/ghc/CONTRIB/pphs/README deleted file mode 100644 index a99d81e8f5..0000000000 --- a/ghc/CONTRIB/pphs/README +++ /dev/null @@ -1,18 +0,0 @@ -"pphs" is a Haskell code pretty-printer, written by Andrew Preece as a -senior honours project at Glasgow. - -== original README ======================================== - -* * RELEASE directory * * - -To find out how to use pphs read the User Guide by -typing xdvi User_Guide - -If you put the output of pphs into a file called Haskell.tex -then you can use Wrapper.tex to produce a ``stand alone'' -dvi file of your program. Just run latex on Wrapper.tex -by typing latex Wrapper then view with xdvi Wrapper - -* * MAINTENANCE directory * * - -Code for pphs program, LaTeX file, report, Makefile, etc. diff --git a/ghc/CONTRIB/pphs/docs/Code.tex b/ghc/CONTRIB/pphs/docs/Code.tex deleted file mode 100644 index 5437457350..0000000000 --- a/ghc/CONTRIB/pphs/docs/Code.tex +++ /dev/null @@ -1,53 +0,0 @@ -\chapter{Project code} - -\section{The program code - {\tt pphs.c}} \label{prog-code} - -\newpage % 8 pages of code a2ps (21.4.94) -\setcounter{page}{50} - -\section{The style file - {\tt pphs.sty}} \label{style-code} - -\begin{verbatim} -% ========================================= -% Definitions for use with the pphs program -% ========================================= - -\typeout{For use with the pphs program} - -% Definitions of commands used by pphs - -\newbox\foo -\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo} -\def\plusplus{\hbox{$+\mkern-7.5mu+$}} -\def\xspa#1{\hskip#1ex} -\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}} - -% User-redefinable commands - typefaces - -\def\keyword{\bf} -\def\iden{\it} -\def\stri{\rm} -\def\com{\rm} -\def\numb{\rm} - -% User-redefinable commands - quote marks - -\def\forquo{\hbox{\rm '}} -\def\escquo{\hbox{\rm '}} -\end{verbatim} - -\section{The make file - {\tt Makefile}} \label{make-code} - -\begin{verbatim} -# Makefile for A Preece's program... etc. - -default: - @echo "Type make pphs to create the program." - -pphs: pphs.c - cc -o pphs pphs.c - -test: pphs - pphs test - latex test.tex -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Error_Messages.tex b/ghc/CONTRIB/pphs/docs/Error_Messages.tex deleted file mode 100644 index e53c960eb9..0000000000 --- a/ghc/CONTRIB/pphs/docs/Error_Messages.tex +++ /dev/null @@ -1,36 +0,0 @@ -\chapter{Error messages given} - -The {\tt pphs} program generates error messages to {\tt stderr}, -with error codes. Normal operation of the program will be -indicated by error code {\tt 0}. - -\section{\tt Call with one file name} - -Error code {\tt 1} is produced when {\tt pphs} is not called with -exactly one filename. Either no filename was given, or too many -filenames were given. Call {\tt pphs} again with one filename. - -\section{\tt File could not be opened} - -Error code {\tt 2} is produced when the filename given when {\tt pphs} -was called could not be opened. This could be because it did not exist, -or was read-protected. Call {\tt pphs} again with a filename that exists -and is readable. - -\section{\tt Stack is too big} - -Error code {\tt 3} is produced when the program has used up too much of -the computer's memory. It is not possible to run {\tt pphs} on this file -without getting more memory for the computer to use. - -\section{\tt Queue is too big} - -Error code {\tt 4} is produced when the program has used up too much of -the computer's memory. It is not possible to run {\tt pphs} on this file -without getting more memory for the computer to use. - -\section{\tt Stack underflow} - -Error code {\tt 5} is produced when the program attempts to remove an item -from a stack in memory that doesn't exist. This should not happen in the -{\tt pphs} program. diff --git a/ghc/CONTRIB/pphs/docs/External_Specification.tex b/ghc/CONTRIB/pphs/docs/External_Specification.tex deleted file mode 100644 index 4190680670..0000000000 --- a/ghc/CONTRIB/pphs/docs/External_Specification.tex +++ /dev/null @@ -1,117 +0,0 @@ -\section{External specification} - -The program is to be run in UNIX by typing {\tt pphs} followed by the -filename containing the Haskell code requiring to be typeset. This will -produce the \LaTeX\ code to stdout. If there is some error, -a suitable error message is to be printed to stderr. The user may, if -desired, direct the output to another file by typing {\tt pphs infilename > outfilename}. -In this case, any error messages must still go to the screen and not the file. - -The input filename may be given in its entirety or the {\tt .hs} extension may be omitted. -In the case where there are two files with the same name, except that one has the -{\tt .hs} extension, to run the program on the file with the extension to its name -the complete filename will be typed. - -The output will consist of the \LaTeX\ code to produce the typeset Haskell -code. As this is to be made easily insertable into another \LaTeX\ document, the output -will not contain any header information such as declarations or definitions. These, -however, can -be contained in a style file which the user will include in their main document. - -Keywords and identifiers are to be distinguished in the result as typeset. -The default for keywords is to be boldface and for identifiers italics. -Numbers not forming part of an identifier are to be in roman by default -while math is to be used where appropriate. - -Haskell uses ASCII characters and combinations of ASCII characters -to substitute for mathematical characters not present on the -keyboard. Where this happens, the program is to replace the ASCII character(s) -with the corresponding mathematical character using the special \LaTeX\ commands -to generate them. The single characters are: -\begin{quote} -\begin{tabular}[t]{@{}cc@{}} -Haskell & Math\\ -{\tt *} & $\times$ -\end{tabular} -\end{quote} -The double characters are: -\begin{quote} -\begin{tabular}[t]{@{}cc@{}} -Haskell & Math\\ -{\tt ++} & {\hbox{$+\mkern-7.5mu+$}}\\ -{\tt :+} & {:}{+}\\ -{\tt <=} & $\leq$\\ -{\tt >=} & $\geq$\\ -{\tt <-} & $\leftarrow$\\ -{\tt ->} & $\rightarrow$\\ -{\tt =>} & $\Rightarrow$ -\end{tabular} -\end{quote} - -The \LaTeX\ system uses special characters to aid with the typesetting. -They are: -\begin{quote} -\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) -\end{quote} -These characters may -appear in the input, so the program must generate the correct \LaTeX\ code to -print them and -avoid having them mess up the typesetting process. - -As the output when typeset must have the same layout as the input, the program -must get the linebreaks and indentation right. As \LaTeX\ is primarily designed for normal -text, it would ignore the linebreaks and indentation in the Haskell file. Therefore -the program must insert them using the correct typesetting commands. In the case of -linebreaks it must recognise where these occur, but for indentation it must also work out -how much space needs to be inserted. - -There are two types of indentation in Haskell programs: left-hand and internal. -For the former, the program must work out what the start of the line is aligned -under in the input file. It then has to calculate how much space is required -to get the line of text to line up with this in the output once typeset. -Take, for instance, the following Haskell example input: -\begin{quote} -\begin{verbatim} -foobar a b = c - where - c = (a, b) -\end{verbatim} -\end{quote} -Notice that the {\tt w} of {\tt where} on the second line lines up -under the {\tt =} on -the first line. Similarly, the {\tt c} on the third line is aligned under the -final letter of {\tt where} on the second line. The result as typeset must -get the indentation correct like this: -\begin{quote} -\begin{tabbing} -foobar a b = c\\ -\newbox\foo -{\setbox\foo\hbox{foobar a b }\hskip\wd\foo}where\\ -{\setbox\foo\hbox{foobar a b wher}\hskip\wd\foo}c = (a, b) -\end{tabbing} -\end{quote} - -For internal indentation, the program must first recognise where it has -occurred. It must then insert the correct amount of space to get alignment -in the output. As \LaTeX\ uses variable-width characters, extra space -may be needed in lines preceding a line within an internal alignment section. -This is necessary if a lower line which -aligns in the input file is longer up to the alignment point, -due to the variable-width characters, than its predecessors -once it has been properly typeset. For example: -\begin{quote} -\begin{verbatim} -lilli :: a -wmwm :: b -\end{verbatim} -\end{quote} -becomes -\begin{quote} -\begin{tabular}[t]{@{}l@{\ }c@{\ }l} -lilli & :: & a\\ -wmwm & :: & b\\ -\end{tabular} -\end{quote} -Notice how {\tt lilli} is longer than {\tt wmwm} in the input file style -using fixed-width font but shorter when using the variable-width font -of the typeset output. diff --git a/ghc/CONTRIB/pphs/docs/Faults.tex b/ghc/CONTRIB/pphs/docs/Faults.tex deleted file mode 100644 index 1c38984bb7..0000000000 --- a/ghc/CONTRIB/pphs/docs/Faults.tex +++ /dev/null @@ -1,66 +0,0 @@ -\chapter{Things that don't work} \label{faults} - -The {\tt pphs} program has some deficiencies that cause it to not always produce the -correct code. These are detailed in this chapter. - -\section{Internal alignment} - -The program can deal only with simple internal alignment. It cannot deal with a -situation where there is more than one column where internal alignment is occurring -on the same line. This can occur when two sections of internal -alignment overlap by having lines in common or where one section is wholly within another. -When this happens, {\tt pphs} will only -line up one occurrence of internal alignment on each line. - -Related is left alignment under a section of internal alignment. Take this earlier example. -\begin{quote} -\input{Haskell_leftindent1} -\end{quote} -This is how this code is typeset by {\tt pphs}: -\begin{quote} -\input{LaTeX_leftindent1} -\end{quote} -Notice how the {\bf where} on the third line doesn't line up under the {\it gcd\/}$'$ on -the second. The reason for this -is the \LaTeX\ {\tt tabular} section does not respect any spaces that occur at the end -of the right hand edge of the left hand column such as those after -{\tt gcd x y} and instead moves the central column left -so it is only one space away from the longest piece of text in the left hand column, -in this case {\iden gcd\/}\xspa1 {\iden x\/}\xspa1 {\iden y\/}. -The left indentation of the lines under the internal alignment section does not take this -movement into account and so if a line is indented beyond the end of the text in the first -column of the last line of the internal alignment section then it may be incorrectly -positioned and therefore will not align with what it was aligned with in the original -program. Should a piece of text in the left hand column be longer once typeset than what was -previously the longest, due to the variable-width characters used by \LaTeX , -then the second and third columns will get moved to the right, and so, similarly, -any code indented under the other columns will be wrongly positioned. - -Where a section of internal alignment coincides with the bottom of the user's page, -it can run off the bottom of the page. This is because the {\tt tabular} environment -used for internal alignment sections does not allow pagebreaks. Therefore the pagebreak -will come after the section has been completed. - -\section{Mathematical symbols} - -Mathematical symbols are always written in math font. This means that where, say, -comments are re-defined to be in typewriter font, as in the following -example, any mathematical symbols in the comments -will appear in math font, rather than typewriter font. -\begin{quote} -\def\com{\tt} -\input{LaTeX_comment} -\end{quote} - -\section{Left indentation} - -Where a line is indented beyond the end of its predecessor and aligns under another -line, but when typeset, the predecessor becomes longer than the indentation level -due to the variable-width characters, the line's indentation will appear to be under the -predecessor line. - -\section{Floating point numbers} - -Currently {\tt pphs} will recognise strings such as {\tt 3.} or {\tt 5.6e} as -valid floating point numbers. This needs rectifying so only valid floating -point numbers are recognised.
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Future_Work.tex b/ghc/CONTRIB/pphs/docs/Future_Work.tex deleted file mode 100644 index 4bf7b89692..0000000000 --- a/ghc/CONTRIB/pphs/docs/Future_Work.tex +++ /dev/null @@ -1,30 +0,0 @@ -\chapter{Things remaining to be implemented} - -Due to pressure of time, not everything that was planned to be included in -{\tt pphs} was implemented. This chapter details these things. - -\section{Faults} - -The faults detailed in Chapter~\ref{faults} remain to be rectified. The fault -regarding multiple columns of internal alignment would, it seems, require a -major rethink on the way internal alignment is handled by {\tt pphs}, perhaps -using the {\tt tabbing} environment with tabs and tabstops, rather than the -{\tt tabular} environment as at present. This could also -be extended to left indentation to solve the problem with indentation under -internal alignment section. Elimination of the {\tt tabular} sections would solve -the problem of pagebreaks during internal alignment sections. - -\section{Parsing} - -Currently, {\tt pphs} only does limited parsing. This could be altered to -give a full parse by restructuring into Lex. This would be better because -it would allow sections of code to be classified more easily once they were -broken down. - -\section{Literate Haskell} - -It has been suggested that {\tt pphs} be extended to accept Literate Haskell -files as input. This is where the program code lines all start with {\tt >} -and plain text is written between sections of code to document the file. -This would be called by an additional option, say {\tt -l}, and would typeset -the sections of Haskell code, whilst leaving the text sections alone.
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_char.tex b/ghc/CONTRIB/pphs/docs/Haskell_char.tex deleted file mode 100644 index 265b063bce..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_char.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{verbatim} --- Character functions - -minChar, maxChar :: Char -minChar = '\0' -maxChar = '\255' -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex b/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex deleted file mode 100644 index b4942bb9c2..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex +++ /dev/null @@ -1,12 +0,0 @@ -% From Haskell report PreludeComlex.hs -\begin{verbatim} -instance (RealFloat a) => Num (Complex a) where - (x:+y) + (x':+y') = (x+x') :+ (y+y') - (x:+y) - (x':+y') = (x-x') :+ (y-y') - (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') - negate (x:+y) = negate x :+ negate y - abs z = magnitude z :+ 0 - signum 0 = 0 - signum z@(x:+y) = x/r :+ y/r where r = magnitude z - fromInteger n = fromInteger n :+ 0 -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex b/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex deleted file mode 100644 index 80d17b6a16..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex +++ /dev/null @@ -1,4 +0,0 @@ -\begin{verbatim} -fst :: (a,b) -> a -fst (x,_) = x -\end{verbatim} diff --git a/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex b/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex deleted file mode 100644 index aac11d82e8..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{verbatim} -gcd :: Int -> Int -> Int -gcd x y = gcd' (abs x) (abs y) - where gcd' x 0 = x - gcd' x y = gcd' y (x `rem` y) -\end{verbatim} - diff --git a/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex b/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex deleted file mode 100644 index 09533c8a08..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex +++ /dev/null @@ -1,9 +0,0 @@ -% From cvh/Public/GBC/Source/Gm7.hs -\begin{verbatim} -eval :: GmState -> [GmState] -eval state = state: restStates - where - restStates | gmFinal state = [] - | otherwise = eval nextState - nextState = doAdmin (step state) -\end{verbatim} diff --git a/ghc/CONTRIB/pphs/docs/Haskell_math.tex b/ghc/CONTRIB/pphs/docs/Haskell_math.tex deleted file mode 100644 index 2e67e31e05..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_math.tex +++ /dev/null @@ -1,5 +0,0 @@ -\begin{verbatim} --- list concatenation (right-associative) -(++) :: [a] -> [a] -> [a] -xs ++ ys = foldr (:) ys xs -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_simple.tex b/ghc/CONTRIB/pphs/docs/Haskell_simple.tex deleted file mode 100644 index 4ca2bb50c7..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_simple.tex +++ /dev/null @@ -1,5 +0,0 @@ -\begin{verbatim} -foobar a b = c - where - c = a + b -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_string1.tex b/ghc/CONTRIB/pphs/docs/Haskell_string1.tex deleted file mode 100644 index 0284da1e3c..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_string1.tex +++ /dev/null @@ -1,8 +0,0 @@ -\begin{verbatim} --- File and channel names: - -stdin = "stdin" -stdout = "stdout" -stderr = "stderr" -stdecho = "stdecho" -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex b/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex deleted file mode 100644 index a8518c3e76..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{verbatim} -Horrible typewriter font - where - everything is the same - fixed width characters - no highlighting -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/How.tex b/ghc/CONTRIB/pphs/docs/How.tex deleted file mode 100644 index 10120131f8..0000000000 --- a/ghc/CONTRIB/pphs/docs/How.tex +++ /dev/null @@ -1,465 +0,0 @@ -\chapter{How it does it} - -This chapter explains in detail how the program {\tt pphs} was implemented -from a programmer's viewpoint. It was implemented in the C programming -language, as this is a commonly used language often used for writing UNIX tools. -The program code is shown in Appendix~\ref{prog-code} and the makefile in -Appendix~\ref{make-code}. - -\section{General sequence of events} - -When the {\tt pphs} program is run, the program first finds out what, if any, -options it has been called with. If any have been specified, the appropriate -variables are set. The program then checks it has been called with exactly one -further argument. If not, the program terminates with an -explanatory error message. If called correctly, the program then checks that the -supplied argument is the name of a file that exists and is readable. -The program is normally used -on files ending with a {\tt .hs} extension. When called with a filename -with no extension and that file is not found, then it appends the extension and searches -for that file. If no file with that name is found or the file is unreadable, an -error message is produced and the program terminates. If the file is found, the -program starts the typesetting process by writing out the opening -\LaTeX\ command to {\tt stdout}. -This defines the \LaTeX\ environment which the program exploits to do the typesetting. -It then initialises the variables used in the program. - -This done, the first character is read. The program enters a loop and keeps -reading characters until the end of the file is reached. As each character is read -in, its typeface is established and it is stored with its typeface in something -called the {\em line store\/}. If any left indentation is -encountered, the correct characters to be skipped are identified from the {\em left -indentation stack} and copied into the line store. Internal alignment is checked -for and if any is found, appropriate variables are set accordingly. Each stored line is -added to both the left indentation stack and the {\em writing queue}. When the value of the -internal alignment changes, or it has been established that the first line in the writing -queue is not part of any internal alignment section, the lines in the queue are written out. - -Once all the lines are written out, {\tt pphs} then writes the closing \LaTeX\ command -and terminates. - -\section{Basic storage unit for a line of code} \label{line-store} - -The basic storage unit used in {\tt pphs} is the line store unit. -This stores the details of one line of Haskell code. These are -the characters on the line, the typeface associated with each -character, the length of the line, the indentation level and the position of -any internal alignment in the line. - -In the C program, {\tt ElementType} is the structure used for this type. This has -five parts: -\begin{itemize} -\item {\tt chars} which stores the characters used on the line of Haskell -code - -\item {\tt typeface} which stores the typeface values associated with the -characters on that line - -\item {\tt indentation} which stores the level of the line's indentation - -\item {\tt length} which stores the length of the line - -\item {\tt col} which stores the column where any internal alignment occurs or -is set to {\tt 0} if there is none -\end{itemize} -The variable {\tt store} in the main program is of type {\tt ElementType} and -is used as the basic storage unit for the current line. Its C declaration is -\begin{quote} -\begin{verbatim} -typedef struct ElementType_Tag { - char chars[MAXLINELENGTH]; - enum face typeface[MAXLINELENGTH]; - int indentation, length, col; -} ElementType; -\end{verbatim} -\end{quote} - -\section{Stack of lines for left indentation} - -Due to \LaTeX 's variable width characters, {\tt pphs} cannot simply uses spaces -for the left indentation as in the input Haskell file. It has to work out how far -each line is indented by finding out what it is indented under. As each line is -completed, it is added to a stack of lines, each line being stored in a basic -storage unit. If the line at the top of the stack is of a greater or equal -indentation level and of a lesser or equal length, then it is no -longer required for calculating typeset indentation -and can be disposed of. Once all lines of greater indentation level have been removed -from the top of the stack, the current line can then be added. - -When a line's indentation level, in terms of the number of spaces used in the -input, has been determined, {\tt pphs} has to find -out the characters that determine the actual typeset length of the indentation. To get this, -{\tt pphs} looks down the stack until it comes to a line whose indentation is less than -that of the current line and whose length is greater than the indentation level of the -current line. Once a suitable line is found, its characters and typefaces are copied -into the line store of the current line; then the rest of the current line is read in, -overwriting the characters beyond the indentation level. If there is no line preceding -the current one that is as long as the indentation level of the current line, spaces -are placed in the line store instead. - -A special case has been made for left indentation. Most of the time, the left-hand edge -of the characters will be aligned, but where a {\tt |} is aligned under an {\tt =} sign, it is -centered under the sign. This will be the case for any further {\tt |} symbols aligned -under this {\tt =} sign. - -The type {\tt StackType} is used in the program for the stack. This makes a stack of -the basic line storage units of {\tt ElementType}, together with a set of functions available -for use with stacks. These are {\tt CreateStack}, which returns an empty stack; -{\tt IsEmptyStack}, which returns {\tt 1} if the stack which it is called with is empty, -{\tt 0} otherwise; {\tt Push}, which takes a stack and an element and returns the stack -with the element pushed onto the top; {\tt Top}, which takes a stack and returns the top -element of the stack; {\tt Pop}, which takes a stack and returns it with the top element -removed; and {\tt PopSym}, which is the same as {\tt Pop} except that it does not free the -memory used by the top element - this function was found necessary to fix a fault caused by -returning to a stack's previous state, having popped off elements in the interim period. - -\section{Internal alignment identification} - -Internal alignment is deemed to have occurred when a character matches the one -immediately above it, the preceding characters in both lines are spaces, and there is -more than one space preceding the character on at least one of the lines. - -To check for this in {\tt pphs}, the current position on the line, indicated by -the linecounter, must be greater than one because either the current line or -the previous line will be required to have two spaces before the current position. The current -line will be located in the line store and the previous line will be at the rear of the queue -of lines waiting to be written out. - -One special case has been implemented for internal alignment. This is to allow Haskell -type declarations, such as in the example below, to align with their corresponding function -definitions. -\begin{quote} -\input{Haskell_internalalign2} -\end{quote} -The {\tt =} sign can be under either the first or second {\tt :} symbol for the -internal alignment to be recognised. - -\section{Typefaces and mathematical characters} - -Each character has a typeface value associated with it. Normally, this will -indicate the type of token the character is part of, either keyword, identifier, -string, comment, number or maths symbol, but where Haskell uses an ASCII character -simulation of a mathematical character or some other special symbol, the typeface -value will indicate this as well. - -In the program, the typeface values are of the -enumerated type called {\tt face}, which has the values shown in Table~\ref{tf-val}. -They are used in the basic storage unit {\tt ElementType} in the {\tt typeface} part. - -\begin{table} -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em value\/} & {\em indicates\/} \\ \hline -{\tt KW} & keyword \\ -{\tt ID} & identifier \\ -{\tt IE} & exponent identifier \\ -{\tt ST} & string \\ -{\tt SE} & exponent string \\ -{\tt CO} & comment \\ -{\tt CE} & exponent comment \\ -{\tt NU} & number \\ -{\tt NE} & exponent number \\ -{\tt MA} & maths \\ -{\tt SP} & space \\ -{\tt LC} & line comment \\ -{\tt RC} & regional comment begin \\ -{\tt CR} & regional comment end \\ -{\tt BF} & backwards/forwards quote \\ -{\tt FQ} & forwards quote \\ -{\tt EQ} & escape quote \\ -{\tt DQ} & double quote begin \\ -{\tt QD} & double quote end \\ -{\tt EE} & escape double quote \\ -{\tt DC} & second part of double character \\ -{\tt DP} & double plus \\ -{\tt CP} & colon plus \\ -{\tt LE} & less than or equal to \\ -{\tt GE} & greater than or equal to \\ -{\tt LA} & left arrow \\ -{\tt RA} & right arrow \\ -{\tt RR} & double right arrow \\ -{\tt TI} & times \\ -{\tt EX} & double exponent character \\ -{\tt XP} & exponent \\ -{\tt BE} & bar aligned under equals \\ \hline -\end{tabular} -\end{center} -\caption{Typeface values} \label{tf-val} -\end{table} - -\subsection{Current character and retrospective update} - -The {\tt pphs} program has to determine the typeface of a character without knowledge of the -characters to follow. Therefore it allocates the value depending on the status -of various boolean variables. This may subsequently be found to be wrong once the remaining -characters of that token have been read. - -In the case of keywords and double characters, these are only identifiable -as such once all the characters of the token have been read in. Having established -the existence of a keyword or double character, {\tt pphs} then goes back and changes -the typeface values for the appropriate characters. - -The functions {\tt CheckForDoubleChar} and {\tt CheckForKeyword} perform this in the -program. - -\section{Writing lines out} - -Lines are written to {\tt stdout}, but not immediately on being read in. Instead they -are held back while it is established whether or not they form part of a section of -internal alignment. - -Before any typeset Haskell code is written, {\tt pphs} writes an opening \LaTeX\ command -{\tt \char'134 begin\char'173 tabbing\char'175 } to {\tt stdout}. This defines the -\LaTeX\ environment that the typeset code will be written in. At the end, -{\tt \char'134 end\char'173 tabbing\char'175 } is written to terminate this -environment. - -\subsection{The line queue} - -Lines are stored in a queue while they are waiting to be written out. -The elements of the queue are the basic line storage units described in -Section~\ref{line-store}. - -In the program, the queue is of type {\tt QueueType} -and a set of functions related to queues is available. This set consists of -{\tt CreateQueue}, which returns an empty queue; {\tt IsEmptyQueue}, which takes -a queue and returns {\tt 1} if the queue is empty, {\tt 0} otherwise; {\tt LengthOfQueue}, -which takes a queue and returns its length; {\tt FrontOfQueue}, which takes a queue and -returns a pointer to its front element; {\tt RearOfQueue}, which takes a queue and returns -a pointer to its rear element; {\tt AddToQueue}, which takes a queue and an element and -returns the queue with the element added to the rear; {\tt TakeFromQueue}, which takes -a queue and returns the queue with the front element removed. - -The last line in the queue is inspected to search -for internal alignment; if any is found, the internal alignment variable of that -line is altered accordingly. - -\subsection{When lines are written} - -The queue is written out by the function {\tt WriteQueue} when a section of internal -alignment is commenced or terminated -or when it has been established that there is no internal alignment involving the first line -in the queue. If the section being written out has been found to have -no internal alignment, then the last line is retained -in the queue because it may form part of the next section of internal alignment. - -At the end of the input, {\tt WriteRestOfQueue} writes all the lines remaining in the queue. -This is because the last line of Haskell code will not form part of any further section of -internal alignment and can therefore be written out. Facilities -are provided in the function {\tt WriteLine} to avoid writing the last newline -character at the end of the Haskell -file, as this would create an unwanted blank line in the final document. - -\subsection{Writing a line} - -The function {\tt WriteLine} is used in {\tt pphs} to write out one line. This is -called from either {\tt WriteQueue} or {\tt WriteRestOfQueue} and is supplied with -a basic line storage unit containing the line needing to be written out together with a -flag stating whether or not a \LaTeX\ newline character is required. - -If a line has any left indentation, this is written out first by calling the function -{\tt WriteSkipover}. The rest of the line is then written out by {\tt WriteWords} -followed if necessary by the newline character. Both these functions are given -the current line in the line store. - -\subsection{Writing left indentation} - -As \LaTeX\ uses variable width characters, fixed width spaces cannot be used for the -left indentation. Instead, the width of the characters above the current line needs -to be skipped. The {\tt \char'134 skipover} command, defined in the {\tt pphs.sty} -style file (see Section~\ref{style-file}), is used by the function {\tt WriteSkipover} -to get \LaTeX\ to do this. The command is supplied with the typefaces and characters -in the lines above, and, with this, \LaTeX\ creates the correct amount of -indentation in the typeset result. The typefaces and characters are written in -braces as the argument to {\tt \char'134 skipover} by calling {\tt WriteStartFace}, -{\tt WriteChar}, {\tt WriteSpaces} and {\tt WriteFinishFace}. The typeface functions -are called with the typeface value whereas the other two are given the line store, -current position and where the end of the skipover section is. - -Using this specially defined {\tt \char'134 skipover} command avoids having to get -information back from \LaTeX , therefore keeping the information flow unidirectional. - -\subsection{Writing the rest of a line} - -The function {\tt WriteWords} writes out the indented line once any left indentation -has been dealt with. Starting at the indentation level of the line, it uses the functions -{\tt WriteStartFace}, {\tt WriteChar}, {\tt WriteSpaces} and {\tt WriteFinishFace} to -write out each character and its typeface. The typeface functions are called with -the typeface value whereas the other two are given the line store, current position -and where the end of the line is. - -\subsection{Writing \LaTeX\ typeface commands} - -Every character has a typeface associated with it, so at the start and finish of every -line and every time the current typeface changes, typeface commands have to be written -out. This is done by the functions {\tt WriteStartFace} and {\tt WriteFinishFace}. -They write the appropriate \LaTeX\ typeface commands according to the typeface values -given as shown in Table~\ref{tf-comms}. To avoid complications, double characters have -their typefaces written out as part of the character command, therefore they need no -further typeface commands. Similarly, the user-redefinable quote mark characters -have their typeface defined in their definitions, so do not need any more typeface -commands. - -\begin{table} -\begin{center} -\begin{tabular}{|c|l|l|} \hline % ``commands'' to be over two columns -{\em value\/} & \multicolumn{2}{c|}{\em commands\/} \\ \cline{2-3} - & {\em begin\/} & {\em end\/} \\ \hline -{\tt KW} & {\tt \char'173 \char'134 keyword} & {\tt \char'134 /\char'175 }\\ -{\tt ID} & {\tt \char'173 \char'134 iden} & {\tt \char'134 /\char'175 }\\ -{\tt IE} & {\tt \char'173 \char'134 iden} & {\tt \char'134 /\char'175 \$ }\\ -{\tt ST} & {\tt \char'173 \char'134 stri} & {\tt \char'134 /\char'175 }\\ -{\tt SE} & {\tt \char'173 \char'134 stri} & {\tt \char'134 /\char'175 \$ }\\ -{\tt CO} & {\tt \char'173 \char'134 com} & {\tt \char'134 /\char'175 }\\ -{\tt CE} & {\tt \char'173 \char'134 com} & {\tt \char'134 /\char'175 \$ }\\ -{\tt NU} & {\tt \char'173 \char'134 numb} & {\tt \char'134 /\char'175 }\\ -{\tt NE} & {\tt \char'173 \char'134 numb} & {\tt \char'134 /\char'175 \$ }\\ -{\tt MA} & {\tt \$ } & {\tt \$ }\\ -{\tt SP} & & \\ -{\tt LC} & & \\ -{\tt RC} & & \\ -{\tt CR} & & \\ -{\tt BF} & & \\ -{\tt FQ} & & \\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|l|} \hline -{\em value\/} & \multicolumn{2}{c|}{\em commands\/} \\ \cline{2-3} - & {\em begin\/} & {\em end\/} \\ \hline -{\tt EQ} & & \\ -{\tt DQ} & & \\ -{\tt QD} & & \\ -{\tt EE} & & \\ -{\tt DC} & & \\ -{\tt DP} & & \\ -{\tt CP} & & \\ -{\tt LE} & & \\ -{\tt GE} & & \\ -{\tt LA} & & \\ -{\tt RA} & & \\ -{\tt RR} & & \\ -{\tt TI} & {\tt \$ } & {\tt \$ } \\ -{\tt EX} & {\tt \$ } & \\ -{\tt XP} & {\tt \$ } & \\ -{\tt BE} & & \\ \hline -\end{tabular} -\end{center} -\caption{Typeface values and related \LaTeX\ commands} \label{tf-comms} -\end{table} - -\subsection{Writing characters} - -{\tt WriteChar} is the function which handles writing characters. It takes the line store, -the current position on the line and the end of the current section - either the skipover -section or the writing section - and returns the current position on the line which will -have been incremented if a double character has been written. If the first character of -a double character is the last character of a skipover section, it will not be written -so the indentation for that line will fall instead, below the start of the double -character in a line above. Most characters are written out as they were inputted, -but many require special \LaTeX\ code. - -As \LaTeX\ uses embedded typesetting commands, some characters are reserved for this -purpose. Should any of these characters appear in the input Haskell code, {\tt pphs} -has to produce the appropriate \LaTeX\ code to avoid these characters upsetting the typesetting -process. The characters and the replacement \LaTeX\ code are shown in Table~\ref{rep-chars}. -\begin{table} -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em input\/} & {\em \LaTeX\ code output } \\ \hline -{\tt \#} & {\tt \char'134 \#} \\ -{\tt \$} & {\tt \char'134 \$} \\ -{\tt \%} & {\tt \char'134 \%} \\ -{\tt \&} & {\tt \char'134 \&} \\ -{\tt \char'176 } & {\tt \char'134 char'176 } \\ -{\tt \_} & {\tt \char'134 \_} \\ -{\tt \char'134} & {\tt \char'134 hbox\char'173 \$setminus\$\char'175 } \\ -{\tt \char'173} & {\tt \char'134 hbox\char'173 \$\char'134 cal \char'134 char'146 \$\char'175 } \\ -{\tt \char'175} & {\tt \char'134 hbox\char'173 \$\char'134 cal \char'134 char'147 \$\char'175 } \\ -{\tt *} & {\tt \char'134 times}\\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline -{\em input\/} & {\em \LaTeX\ code output } \\ \hline -{\tt ++} & {\tt \char'134 plusplus}\\ -{\tt :+} & {\tt \char'173 :\char'175 \char'173 +\char'175}\\ -{\tt <=} & {\tt \$\char'134 leq\$}\\ -{\tt >=} & {\tt \$\char'134 geq\$}\\ -{\tt <-} & {\tt \$\char'134 leftarrow\$}\\ -{\tt ->} & {\tt \$\char'134 rightarrow\$}\\ -{\tt =>} & {\tt \$\char'134 Rightarrow\$}\\ -{\tt \char'173 -} & {\tt \char'173 \char'134 com \char'134 \char'173 -\char'134 /\char'175 }\\ -{\tt -\char'175 } & {\tt \char'173 \char'134 com -\char'134 \char'175 \char'134 /\char'175 }\\ -{\tt --} & {\tt \char'173 \char'134 rm -\char'175 \char'173 \char'134 rm -\char'175 }\\ \hline -\end{tabular} -\end{center} -\caption{Haskell input and replacement \LaTeX\ code} \label{rep-chars} -\end{table} - -When a mathematical character needs written, {\tt WriteChar} outputs the \LaTeX\ code for -the character rather than the Haskell ASCII character simulation. Some of these -simulations use more than one character, so this could cause problems if some left -indentation is aligned under the second character of such a simulation. It has been -decided that in this case, the output from {\tt pphs} will cause the indented line -to align under the start of the double character rather than the centre or end of it. -The Haskell ASCII simulations and the \LaTeX\ codes that replaces them are shown in -Table~\ref{rep-chars}. The non-standard command {\tt \char'134 plusplus} is defined -in the {\tt pphs.sty} style file (see Section~\ref{style-file}). - -When a {\tt |} symbol is aligned under an {\tt =} sign at the left indentation, -{\tt \char'134 bareq} is output. This command is defined in the {\tt pphs.sty} -style file explained in Section~\ref{style-file} and causes \LaTeX\ to write the bar symbol -centrally in the space it would have taken to write an equals sign, thereby causing -the bar to be positioned centrally under the equals sign it is aligned under and the text -following the bar to align with that after the equals sign. - -For writing spaces, {\tt WriteSpaces}, called with the line store, current position and the -position of the end of the current section, first counts the number of consecutive spaces -to be written before writing out a {\tt \char'134 xspa} command with an argument of -the number of spaces needed. This makes the output code easier to read. The -{\tt \char'134 xspa} command is defined in the {\tt pphs.sty} style file explained -in Section~\ref{style-file}. Any tab characters are treated as spaces by {\tt pphs} -with the number of spaces they represent being calculated from the current position -on the line and the {\tt tablength} variable, which may have been changed from its -default of 8 by the {\tt -t} option at the program call. - -Numbers are written by {\tt WriteChar}, including floating point numbers. - -As \LaTeX\ provides several different quote marks, it was decided that the user -should be able to choose a preferred symbol. An input quote mark {\tt '} can -either be a prime or a quote mark in the output. This requires the program to -determine which it is. In program code this is fine, but in comments or strings -the marks won't necessarily be used in a manner from which it can easily be -determined which symbol is required. In program code, an input {\tt '} is deemed -to be a quote mark if either it is preceded by punctuation or a quote has -already been opened; otherwise it is a prime. Of the quote marks, these can -either be for actual quotes or an escape quote where a quote mark is being quoted. -Special cases has been implemented when the input file contains a quote within a comment -started with a backquote and ended with a forwards quote, and for \LaTeX\ style -quotes in comments started with two backquotes and ended with two forwards quote -marks. All input {\tt '} in strings, other than escape quotes, are treated -as primes. In strings, an input {\tt '} may be an apostrophe, however, there is -little way of telling this.\label{string-apostrophe} One of five different pieces -of \LaTeX\ code can be produced having received {\tt '} as input. -\begin{itemize} -\item {\tt \char'134 forquo} for a forwards quote mark -\item {\tt \char'134 escquo} for an escape (quoted) quote mark -\item {\tt \char'173 \char'134 com '\char'134 /\char'175 } for a forward quote ending a quote -in a comment opened by a backquote -\item {\tt \char'173 \char'134 com ''\char'134 /\char'175 } for two forward quotes ending a quote -in a comment opened by two backquotes -\item {\tt '} for a prime which will be in the math font -\end{itemize} -The first two are commands defined in the {\tt pphs.sty} style file and are -thus user-redefinable as described in Section~\ref{user-adj}. Backquotes, input -as {\tt `}, are either in the comment typeface for backquotes in comments or in -math font elsewhere. - -\subsection{Writing internal alignment} - -To commence a section of internal alignment, either of the functions {\tt WriteQueue} -or {\tt WriteRestOfQueue} write out -{\tt \char'134 begin\char'173 tabular\char'175 \char'173 @\char'173 \char'175 l@\char'173 \char'134 xspa1\char'175 c@\char'173 \char'175 l\char'175 } -before writing the first line of the section. This provides an environment -with three columns. The first column accommodates the Haskell code to the left of the -internal alignment, the second has the symbols that line up vertically, while the third -has the Haskell code to the right. The Haskell code is written complete with its \LaTeX\ -typesetting commands with the addition of {\tt \&} symbols denoting the breaks between -columns. Once the internal alignment section has been completed, the -{\tt \char'134 end\char'173 tabular\char'175 } command is written to terminate the -environment.
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Introduction.tex b/ghc/CONTRIB/pphs/docs/Introduction.tex deleted file mode 100644 index 141fb5940b..0000000000 --- a/ghc/CONTRIB/pphs/docs/Introduction.tex +++ /dev/null @@ -1,137 +0,0 @@ -\chapter{Introduction} - -Documents, such as papers for publication, often include sections -of program code. These have to be specially typeset, as default -typesetting modes are generally intended for plain prose. -It is therefore useful to have a special-purpose system for typesetting -programs for inserting into documents. -Haskell \cite{Haskell-report} is a fairly new functional programming language and does not -yet have a full range of tools available to use with the language, -including one to do typesetting. -The goal of this project, therefore, is to provide a tool to automatically -typeset Haskell programs. - -Many people use the \LaTeX\ system \cite{LaTeX-book} -for typesetting. This uses -embedded typesetting commands in the input to arrange the typesetting. -The typeset result has variable-width characters with a choice of -font styles and sizes available. The page-size, margins and layout -are also controllable by the user. Because \LaTeX\ is so widely used and -so flexible, the tool to be created will be -for use with the \LaTeX\ system. - -Haskell programs are generally written with editors that produce ASCII -text. This has fixed-width characters and one plain font. -Indentation and vertical alignment are simple because -fixed-width characters line up in columns, one below the other. -Haskell avoids having compulsory expression terminators -by using such indentation to delimit expressions. It is thus crucial -that this indentation is retained when the text is typeset. - -The \LaTeX\ system, however, uses variable-width characters, so the indentation -level becomes dependent on the characters under which the text is aligned. -The tabs and spaces that went to make -up the indentation in the original file have to be replaced with a -suitable amount of space to make the text line up with the position -it is aligned with in the original file. - -It is also desirable to have formatting improvements, such as -highlighting keywords and identifiers, as well as to have -proper mathematical characters inserted in place of the -Haskell ASCII approximations. A tool could do this as well. - -Currently the only way of typesetting Haskell program code is to -labouriously insert formatting -commands into the text by hand. The alternative is to print out the programs -verbatim with a plain ASCII-style fixed-width font, but it would be far better -if there were a tool to do the proper typesetting. - -\subsection*{Goals} - -The proposed tool is required to comply to the following requirements: -\begin{itemize} -\item The program must take a file with a Haskell program in it and produce -\LaTeX\ code to stdout. This code must produce the input Haskell program in -typeset style when run through -the \LaTeX\ program. The typeset result must be recognisable as having the same -layout as the input file's Haskell program had. - -\item The typeset result must preserve the parse of the program. - -\item The input file will contain only Haskell code. Any documentation in the file -will be in the form of comments. - -\item The input file will not have any embedded typesetting commands, so -the program must analyse the input and decide for itself what needs to be -done to produce the correct \LaTeX\ code. - -\item The \LaTeX\ code produced must be easy to incorporate into a \LaTeX\ -document such as a paper or book. Thus the produced code must be able -to be incorporated into documents of different page and font sizes. - -\item Keywords and identifiers must be highlightable so as to distinguish -them from the rest of the Haskell program. -The user should be allowed some choice in the typeface used for -highlighting. - -\item Proper mathematical symbols must replace ASCII approximations in the -typeset output. - -\item The program must accept as input -a file of any name and thus not use an inflexible built-in filename. - -\item The program must be in keeping with conventional UNIX style to fit in with -Haskell and \LaTeX , which are also run under UNIX. -\end{itemize} - -\noindent This report describes a program written to satisfy these needs. - -\subsection*{Background} - -Haskell, being a functional programming language, uses functions as its -sole means of programming. This is unlike traditional programming -languages such as C or Pascal, where assignments and procedures are also used. -Haskell also does not normally use expression terminators, such as semi-colons, -but instead relies on the layout of the -program and, in particular, the indentation to determine the context of -lines of code. Lines of code are positioned so they are aligned under particular -points on preceding lines, and this delimits expressions. It is thus -imperative that this indentation be replicated in any attempt to pretty-print -the program code. - -\LaTeX\ is a typesetting program that takes a file with embedded typesetting -commands and produces a file containing typeset text. This is commonly used when -writing documents such as papers and books for publication. Users of \LaTeX\ -can do many things, but anything fancy requires lots of typesetting commands to -be embedded into the input file. Thus typesetting a Haskell program in the -desired way is a considerable task. More simply, a -Haskell program can be displayed in \LaTeX's verbatim mode, but this uses a fixed-width -typewriter font. Verbatim mode does not recognise tab characters, however these can be -replaced with spaces. - -It will be assumed that the user is familiar with Haskell and at least familiar with -preparing basic textual documents with \LaTeX, although it is not required for the -user to understand many of the more involved parts of typesetting with \LaTeX. - -Already in existence is a program called `Phinew' written by Phil Wadler. -This can be found in {\tt \char'176 wadler/bin}. This required the user to supply -typesetting commands embedded in their Haskell programs, meaning that the -user would have to manually pre-process their Haskell code before using -Phinew. Although simpler -than typesetting in \LaTeX, it is still better to have a program -to do all the typesetting automatically, taking an unprepared Haskell -program as input. - -\subsection*{Outline} - -In the remaining sections of this report the functionality of the program written -are discussed; in particular, how all the various layout arrangements are dealt with. The way -in which the program goes about working out what to do is explained, -along with descriptions of the algorithm and data-structures used. Examples -of the input and resulting output are used to illustrate the capabilities -of the program. The various possibilities for the user to decide what happens -are explained, along with details on how to exploit them. The user will -need to know how to incorporate the results into a document so this -is also explained. Finally, the limitations and deficiencies of the -program are detailed complete with an outline of further possible work -which could rectify these problems and make the program more complete. diff --git a/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex b/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex deleted file mode 100644 index 8110ca4a16..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex +++ /dev/null @@ -1,12 +0,0 @@ -\begin{verbatim} -\begin{tabbing} -{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/} - \xspa{1}$=$\xspa{1}{\iden c\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1} - {\iden b\/}\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1} - {\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/} - \xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1} - {\iden b\/} -\end{tabbing} -\end{verbatim}
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex b/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex deleted file mode 100644 index 1c1a67fe91..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex +++ /dev/null @@ -1,6 +0,0 @@ -\begin{tabbing} -{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}$=$\xspa{1}{\iden c\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/}\xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1}{\iden b\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_char.tex b/ghc/CONTRIB/pphs/docs/LaTeX_char.tex deleted file mode 100644 index 7b5a7c83c6..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_char.tex +++ /dev/null @@ -1,9 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com Character\/}\xspa{1}{\com functions\/}\\ -\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden minChar\/}$,$\xspa{1}{\iden maxChar\/}\xspa{8} & $::$ & \xspa{1}{\iden Char\/}\\ -{\iden minChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 0\/}\forquo \\ -{\iden maxChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 255\/}\forquo -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex b/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex deleted file mode 100644 index 324be0b648..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex +++ /dev/null @@ -1,3 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com note\/}\xspa{1}{\com that\/}\xspa{1}{\com x\/}\xspa{1}$+$\xspa{1}{\com y\/}\xspa{1}$=$\xspa{1}{\com z\/} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex deleted file mode 100644 index 069691a88d..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex +++ /dev/null @@ -1,13 +0,0 @@ -\begin{tabbing} -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\keyword instance\/}\xspa{2}$(${\iden RealFloat\/}\xspa{1}{\iden a\/}$)$\xspa{1} & $\Rightarrow$ & \xspa{1}{\iden Num\/}\xspa{1}$(${\iden Complex\/}\xspa{1}{\iden a\/}$)$\xspa{2}{\keyword where\/}\\ -\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$+$\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$+${\iden x\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden y\/}$+${\iden y\/}$')$\\ -\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$-$\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$-${\iden x\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden y\/}$-${\iden y\/}$')$\\ -\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$\times $\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$\times ${\iden x\/}$'-${\iden y\/}$\times ${\iden y\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden x\/}$\times ${\iden y\/}$'+${\iden y\/}$\times ${\iden x\/}$')$\\ -\skipover{{\keyword inst\/}}{\iden negate\/}\xspa{1}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{7} & $=$ & \xspa{2}{\iden negate\/}\xspa{1}{\iden x\/}\xspa{1}{:}{+}\xspa{1}{\iden negate\/}\xspa{1}{\iden y\/}\\ -\skipover{{\keyword inst\/}}{\iden abs\/}\xspa{1}{\iden z\/}\xspa{15} & $=$ & \xspa{2}{\iden magnitude\/}\xspa{1}{\iden z\/}\xspa{1}{:}{+}\xspa{1}{\numb 0\/}\\ -\skipover{{\keyword inst\/}}{\iden signum\/}\xspa{1}{\numb 0\/}\xspa{12} & $=$ & \xspa{2}{\numb 0\/}\\ -\skipover{{\keyword inst\/}}{\iden signum\/}\xspa{1}{\iden z@\/}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{5} & $=$ & \xspa{2}{\iden x\/}$/${\iden r\/}\xspa{1}{:}{+}\xspa{1}{\iden y\/}$/${\iden r\/}\xspa{2}{\keyword where\/}\xspa{1}{\iden r\/}\xspa{1}$=$\xspa{1}{\iden magnitude\/}\xspa{1}{\iden z\/}\\ -\skipover{{\keyword inst\/}}{\iden fromInteger\/}\xspa{1}{\iden n\/}\xspa{7} & $=$ & \xspa{2}{\iden fromInteger\/}\xspa{1}{\iden n\/}\xspa{1}{:}{+}\xspa{1}{\numb 0\/} -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex deleted file mode 100644 index e668990f3d..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex +++ /dev/null @@ -1,8 +0,0 @@ -\begin{tabbing} -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden gcd\/}\xspa{7} & $::$ & \xspa{1}{\iden Int\/}\xspa{1}$\rightarrow$\xspa{1}{\iden Int\/}\xspa{1}$\rightarrow$\xspa{1}{\iden Int\/}\\ -{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4} & $=$ & \xspa{1}{\iden gcd\/}$'$\xspa{1}$(${\iden abs\/}\xspa{1}{\iden x\/}$)$\xspa{1}$(${\iden abs\/}\xspa{1}{\iden y\/}$)$\\ -\end{tabular}\\ -\skipover{{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4}$=$\xspa{1}}{\keyword where\/}\xspa{1}{\iden gcd\/}$'$\xspa{1}{\iden x\/}\xspa{1}{\numb 0\/}\xspa{1}$=$\xspa{1}{\iden x\/}\\ -\skipover{{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4}$=$\xspa{1}{\keyword where\/}\xspa{1}}{\iden gcd\/}$'$\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{1}$=$\xspa{1}{\iden gcd\/}$'$\xspa{1}{\iden y\/}\xspa{1}$(${\iden x\/}\xspa{1}$`${\iden rem\/}$`$\xspa{1}{\iden y\/}$)$ -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex deleted file mode 100644 index d175774169..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex +++ /dev/null @@ -1,8 +0,0 @@ -\begin{tabbing} -{\iden eval\/}\xspa{1}$::$\xspa{1}{\iden GmState\/}\xspa{1}$\rightarrow$\xspa{1}$[${\iden GmState\/}$]$\\ -{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}{\iden state\/}$:$\xspa{1}{\iden restStates\/}\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\iden restStates\/}\xspa{1}$|$\xspa{1}{\iden gmFinal\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}$[]$\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}{\iden restStates\/}\xspa{1}}$|$\xspa{1}{\iden otherwise\/}\xspa{1}$=$\xspa{1}{\iden eval\/}\xspa{1}{\iden nextState\/}\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\iden nextState\/}\xspa{2}$=$\xspa{1}{\iden doAdmin\/}\xspa{1}$(${\iden step\/}\xspa{1}{\iden state\/}$)$ -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_math.tex b/ghc/CONTRIB/pphs/docs/LaTeX_math.tex deleted file mode 100644 index 4b4198dde3..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_math.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com list\/}\xspa{1}{\com concatenation\/}\xspa{1}$(${\com right\/}$-${\com associative\/}$)$\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -$($\plusplus$)$\xspa{20} & $::$ & \xspa{1}$[${\iden a\/}$]$\xspa{1}$\rightarrow$\xspa{1}$[${\iden a\/}$]$\xspa{1}$\rightarrow$\xspa{1}$[${\iden a\/}$]$\\ -{\iden xs\/}\xspa{1}\plusplus\xspa{1}{\iden ys\/}\xspa{16} & $=$ & \xspa{2}{\iden foldr\/}\xspa{1}$(:)$\xspa{1}{\iden ys\/}\xspa{1}{\iden xs\/} -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex b/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex deleted file mode 100644 index 956fc496c7..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex +++ /dev/null @@ -1,5 +0,0 @@ -\begin{tabbing} -{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}$=$\xspa{1}{\iden c\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/}\xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1}{\iden b\/} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex deleted file mode 100644 index 6472e1d6c1..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex +++ /dev/null @@ -1,10 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com File\/}\xspa{1}{\com and\/}\xspa{1}{\com channel\/}\xspa{1}{\com names\/}$:$\\ -\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden stdin\/}\xspa{7} & $=$ & \xspa{2}{\rm ``}{\stri stdin\/}{\rm "}\\ -{\iden stdout\/}\xspa{6} & $=$ & \xspa{2}{\rm ``}{\stri stdout\/}{\rm "}\\ -{\iden stderr\/}\xspa{6} & $=$ & \xspa{2}{\rm ``}{\stri stderr\/}{\rm "}\\ -{\iden stdecho\/}\xspa{5} & $=$ & \xspa{2}{\rm ``}{\stri stdecho\/}{\rm "} -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex b/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex deleted file mode 100644 index 696a2b6666..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex +++ /dev/null @@ -1,10 +0,0 @@ -\begin{tabbing} -{\iden main\/}\xspa{1}$=$\xspa{1}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\rm ``}{\stri please\/}\xspa{1}{\stri type\/}\xspa{1}{\stri a\/}\xspa{1}{\stri filename\hbox{$\setminus$}n\/}{\rm "}\xspa{1}{\iden exit\/}\xspa{1}$($\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden readChan\/}\xspa{1}{\iden stdin\/}\xspa{1}{\iden exit\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden userInput\/}\xspa{1}$\rightarrow$\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\keyword let\/}\xspa{1}$(${\iden name\/}\xspa{1}$:$\xspa{1}{\iden \_\/}$)$\xspa{1}$=$\xspa{1}{\iden lines\/}\xspa{1}{\iden userInput\/}\xspa{1}{\keyword in\/}\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\iden name\/}\xspa{1}{\iden exit\/}\xspa{1}$($\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden ioerror\/}\xspa{1}$\rightarrow$\xspa{1}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden ioerror\/}\xspa{1}$\rightarrow$\xspa{1}}{\rm ``}{\stri can\/}$'${\stri t\/}\xspa{1}{\stri open\/}\xspa{1}{\stri file\/}{\rm "}\xspa{1}{\iden exit\/}\xspa{1}{\iden done\/}$)$\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden contents\/}\xspa{1}$\rightarrow$\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\iden contents\/}\xspa{1}{\iden exit\/}\xspa{1}{\iden done\/}$))))$ -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex b/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex deleted file mode 100644 index 668ce57838..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex +++ /dev/null @@ -1,9 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com Character\/}\xspa{1}{\com functions\/}\\ -\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden minChar\/}$,$\xspa{1}{\iden maxChar\/}\xspa{8} & $:\,:$ & \xspa{1}{\iden Char\/}\\ -{\iden minChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 0\/}\forquo \\ -{\iden maxChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 255\/}\forquo -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/Problem_Definition.tex b/ghc/CONTRIB/pphs/docs/Problem_Definition.tex deleted file mode 100644 index 8659bcc8dd..0000000000 --- a/ghc/CONTRIB/pphs/docs/Problem_Definition.tex +++ /dev/null @@ -1,37 +0,0 @@ -\section{Problem definition} - -The problem is that a system is needed to typeset Haskell programs -to be inserted into documents. This would be useful in, for -instance, preparing papers for publication that are to include -Haskell programs. - -Haskell is a fairly new functional programming language and does not -as yet have a full range of tools available to use with the language. - -Many people use the \LaTeX\ system for typesetting. This uses -embedded typesetting commands in the input to arrange the typesetting. -The result as typeset has variable-width characters with a choice of -font styles and sizes available. The page-size, margins and layout -are also controllable by the user. - -Haskell programs are generally written on editors that produce ASCII -text. This has fixed-width characters and one plain font. - -In Haskell, the language avoids using -line terminators by having indentation to indicate the contextual meaning of -each line. It is thus crucial that this indentation is retained -when the text is put into \LaTeX. However as the \LaTeX\ system uses -variable width characters, the indentation -level is dependent on the characters under which the text is aligned. -The tabs and spaces that went to make -up the indentation in the original file have to be replaced with a -suitable amount of space to make the text line up with the position with which it -is aligned in the original file. - -It is also desirable to have -formatting improvements such as highlighting keywords and identifiers as well as -inserting proper mathematical characters in place of the Haskell-ASCII simulations. - -Currently the only way of doing this is by labouriously inserting formatting -commands into the text by hand. The alternative is to print out the programs -verbatim with plain ASCII-style fixed-width font. diff --git a/ghc/CONTRIB/pphs/docs/Project_Documents.tex b/ghc/CONTRIB/pphs/docs/Project_Documents.tex deleted file mode 100644 index 5833c2a032..0000000000 --- a/ghc/CONTRIB/pphs/docs/Project_Documents.tex +++ /dev/null @@ -1,7 +0,0 @@ -\chapter{Project documents} - -These are the original project documents from 19th January 1994. - -\input{Problem_Definition} -\input{Statement_Of_Requirements} -\input{External_Specification} diff --git a/ghc/CONTRIB/pphs/docs/Report.tex b/ghc/CONTRIB/pphs/docs/Report.tex deleted file mode 100644 index d37dd0d153..0000000000 --- a/ghc/CONTRIB/pphs/docs/Report.tex +++ /dev/null @@ -1,49 +0,0 @@ -\documentstyle[12pt,fleqn,rep,pphs]{report} -\renewcommand{August 1994} -\begin{document} - -\def\sect{\section} -\def\subsect{\subsection} - -% Title page -\title{Literate Haskell} -\author{A. Preece \\\\ University of Glasgow} -\maketitle - -\setcounter{page}{2} -\tableofcontents - -\input{Introduction} -\input{What} -\input{How} -\input{Uses} -\input{Error_Messages} -\input{Faults} -\input{Future_Work} - -\appendix - -\input{Project_Documents} -\input{User_Documents} -\input{Code} - -\begin{thebibliography}{9} -\addcontentsline{toc}{chapter}{Bibliography} - -\bibitem{Haskell-report} -Hudak, P., Peyton Jones, S., Wadler, P., et al., {\em Haskell, Report on the Programming Language\/} -(1992) - -\bibitem{LaTeX-book} -Lamport, L., {\em \LaTeX : A Document Preparation System\/} -(Addison-Wesley, 1986) - -\end{thebibliography} - -\chapter*{Acknowledgements} -\addcontentsline{toc}{chapter}{Acknowledgements} - -I am very grateful for the help and advise of Project Supervisor Tom Melham, -and also for the suggestions of Phil Wadler, Richard McPhee, and Mark Pollock. - -\end{document} diff --git a/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex b/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex deleted file mode 100644 index 00b8fd52e4..0000000000 --- a/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex +++ /dev/null @@ -1,32 +0,0 @@ -\section{Statement of requirements} - -There are various things that are required of the solution to the -problem described previously. -\begin{itemize} -\item The program must take a file with a Haskell program in it and produce -\LaTeX\ code to stdout. This code must produce that Haskell program in -typeset style when run through -the \LaTeX\ program. The result as typeset must be recognisable as having the same -layout as the input file's Haskell program had. - -\item The input file will contain only Haskell code. Any documentation in the file -will be in the form of comments. - -\item The input file will not have any embedded typesetting characters in it so -the program must analyse the input and decide for itself what needs to be -done to produce the correct \LaTeX\ code. - -\item The \LaTeX\ code produced must be easy to incorporate into a \LaTeX\ -document such as a paper or book. Thus the produced code must be able -to be incorporated into documents of different page and font size. - -\item Keywords and identifiers must be highlightable so as to distinguish -them from the rest of the Haskell program. -The user should be allowed some choice in the typeface used for -highlighting. - -\item Generality of use must be retained so as to allow the program to be used in conjunction -with a file of any name and thus not use an inflexible built-in filename. - -\item The program must be in keeping with conventional UNIX style. -\end{itemize} diff --git a/ghc/CONTRIB/pphs/docs/Title.tex b/ghc/CONTRIB/pphs/docs/Title.tex deleted file mode 100644 index e69de29bb2..0000000000 --- a/ghc/CONTRIB/pphs/docs/Title.tex +++ /dev/null diff --git a/ghc/CONTRIB/pphs/docs/UserGuide.tex b/ghc/CONTRIB/pphs/docs/UserGuide.tex deleted file mode 100644 index 5f46b0861a..0000000000 --- a/ghc/CONTRIB/pphs/docs/UserGuide.tex +++ /dev/null @@ -1,9 +0,0 @@ -\documentstyle[12pt,fleqn,a4,pphs]{report} -\begin{document} - -\def\sect{\section*} -\def\subsect{\subsection*} - -\input{UserGuide_Text} - -\end{document} diff --git a/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex b/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex deleted file mode 100644 index 5dc6999ce4..0000000000 --- a/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex +++ /dev/null @@ -1,231 +0,0 @@ -\sect{User guide to {\tt pphs}} - -The program {\tt pphs} typesets programs in the Haskell programming -language for use with the \LaTeX\ intensional text formatting -and typesetting system. It takes -as input a file containing a Haskell program and produces \LaTeX\ -code to {\tt stdout}. There are various different features of this -process. - -\subsect{Left indentation} - -It is in the nature of Haskell programs that indentation is heavily used. As the -indentation is vital to the parsing of the program, any attempt at typesetting -Haskell code must replicate this indentation. Take, for example, the following piece of code. -\begin{quote} -\input{Haskell_leftindent2} -\end{quote} -Note how the third, fifth and sixth lines start at different levels of indentation. -The {\tt pphs} program produces the correct \LaTeX\ code to align these under the -correct position in the preceding lines once typeset. It also selects the correct -line to line up under. Note how the sixth line does not line up -under its predecessor, but under the fourth line. -The code necessary to typeset this is produced, preserving the parsing -order. Once typeset, it will look like this: -\begin{quote} -\input{LaTeX_leftindent2} -\end{quote} -Note that this -example of possible input had no `extra' typesetting commands. - -A line of Haskell code may be indented beyond the end of its predecessor. -Here, {\tt pphs} aligns it with whichever line it is lined up underneath in the -original file, or, if longer than any preceding line, inserts space to correspond -to that in the input file. - -\subsect{Internal alignment} - -Another form of alignment used in Haskell is {\em internal alignment}. This is where -there is vertical alignment of columns other than at the left-hand edge of the -Haskell code. This is typically characterised with a column of the same character -appearing in the program code, and it is this case, along with a -special case, that {\tt pphs} recognises for internal alignment having occurred. -\begin{quote} -\input{Haskell_internalalign1} -\end{quote} -In this example, see how the {\tt =} signs line up, one below the other. This makes -the program more readable, although it does not affect the parsing of the program. -As the purpose of {\tt pphs} is to make Haskell programs even more readable, it -retains this alignment. This example would be typeset to produce the following: -\begin{quote} -\input{LaTeX_internalalign1} -\end{quote} -The special case for internal alignment is a $=$ aligned under a $::$. -This will cause the same effect as would have happened if they were the same -character. - -\subsect{Token highlighting} - -To increase the readability of Haskell programs, {\tt pphs} allows various tokens -to be highlighted. By using different typefaces for some pieces of code, this -distinguishes them from the rest. The user can specify the details of -the highlighting, but the default settings are {\bf bold} for -keywords, {\it italics} for identifiers and {\rm roman} for everything else. -Strings, comments and numbers are also highlightable. - -Note that in the previous example, the keywords {\bf instance} and {\bf where} -are highlighted in bold, whereas the various identifiers are in italics. - -\subsect{Mathematical symbols} - -Rather than simply replicate the ASCII approximations of mathematical symbols -used in Haskell, {\tt pphs} -substitutes the proper symbols in the output. These are shown below. -\begin{center} -\begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt *} & $\times$ \\ -{\tt ++} & {\hbox{$+\mkern-7.5mu+$}} \\ -{\tt :+} & {:}{+} \\ -{\tt <=} & $\leq$ \\ \hline -\end{tabular} \hskip3mm \begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt >=} & $\geq$ \\ -{\tt <-} & $\leftarrow$ \\ -{\tt ->} & $\rightarrow$ \\ -{\tt =>} & $\Rightarrow$ \\ \hline -\end{tabular} -\end{center} - -\subsect{\LaTeX\ typesetting characters} - -\LaTeX\ uses embedded typesetting commands, so {\tt pphs} has to ensure that if -any of the characters used by \LaTeX\ appear in the input Haskell code, the correct -\LaTeX\ code is outputted to typeset them, rather than have the characters interfere -with the typesetting process. The characters used by \LaTeX\ for typesetting are: -\begin{quote} -\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) -\end{quote} -The user of {\tt pphs} need not worry about using any of these characters in Haskell -programs, as this will be dealt with by {\tt pphs} before \LaTeX\ gets to see the code. - -\subsect{How to call it} - -The program is called by typing {\tt pphs} followed by the name of -the file containing the Haskell program to be typeset. If the -filename ends with a {\tt .hs} extension, this may be omitted, -unless another file exists with the same name but no extension. -When no extension is specified, the program will look for a -filename with no extension before looking for a file with the -{\tt .hs} extension. - -For example, if the Haskell program was in a file called {\tt Haskell.hs}, -the program would be called by -\begin{quote} -\tt pphs Haskell.hs -\end{quote} -As the filename ends with a {\tt .hs} extension, the extension may be omitted, provided -there is no file already existing called {\tt Haskell}. If there is no such file -\begin{quote} -\tt pphs Haskell -\end{quote} -would produce the same effect as the original call. - -As the program outputs to {\tt stdout}, the code produced may be -directed to a file by using a {\tt >} symbol after the call, followed by -the name of the file to contain the \LaTeX\ code produced by the -program. Continuing the above example, if the output code is to be in -a file called {\tt Haskell.tex}, the call would now be -\begin{quote} -\tt pphs Haskell.hs > Haskell.tex -\end{quote} -It must be noted that if the file {\tt Haskell.tex} already exists, it must be -renamed or removed before making this call. - -There are three options that can be specified in the program call. -If it is desired that double colon symbols should look like $:\,:$ rather than $::$, -use {\tt -w} in the call. The length of the tab characters in the input file can -be specified with {\tt -t} followed by the length. The default tablength is 8. -If identifiers with subscripts are wanted, eg {\iden ident$_1$\/}, then use {\tt -s}. -These are written in the Haskell file as {\tt ident\_1}. - -If the length of the tabs are 4 and -the wide double colons are required, the example call above would become as follows. -\begin{quote} -\tt pphs -t4w Haskell.hs > Haskell.tex -\end{quote} - -\subsect{What to do with the produced code} - -Before including the \LaTeX\ code in the document, it is necessary -to include definitions of the \LaTeX\ commands used by {\tt pphs}. -This can be done simply by including the style file {\tt pphs.sty} -by adding {\tt pphs} to the option list of the documentstyle -command like thus: -\begin{quote} -\begin{verbatim} -\documentstyle[12pt,a4,pphs]{article} -\end{verbatim} -\end{quote} - -Once this has been done, the file containing the \LaTeX\ code -of the Haskell program code can be included. This is done -using the {\tt \char'134 input} command. If the \LaTeX\ -code is located in a file called {\tt Haskell.tex} then the -command is: -\begin{quote} -\begin{verbatim} -\input{Haskell} -\end{verbatim} -\end{quote} -This can be used in various \LaTeX\ environments such as {\tt quote}, -{\tt figure} or {\tt table} to produce different effects. An example -of possible code is: -\begin{quote} -\begin{verbatim} -\begin{quote} -\input{Haskell} -\end{quote} -\end{verbatim} -\end{quote} -See Lamport, L., {\em \LaTeX : A Document Preparation System\/} -(Addison-Wesley, 1986) for more details. - -\subsect{How to make adjustments to the output} - -The {\tt pphs} program is flexible in that it allows user choice on some aspects -of the appearance of the final result. User choice is allowed in two areas, typefaces -and qoute marks. - -The default settings for typefaces are bold for keywords, italics for identifiers and -roman for everything else that is not in the math typeface. However, keywords, identifiers, -strings, comments and numbers may be in whatever typeface the user chooses. -This is done using the {\tt \char'134 def} command to redefine the typeface commands -used by {\tt pphs}. These are {\tt \char'134 keyword}, {\tt \char'134 iden}, -{\tt \char'134 stri}, {\tt \char'134 com} and {\tt \char'134 numb} respectively. - -For example, to put all comments into typewriter font, use -{\tt \char'134 def\char'134 com\char'173 \char'134 tt\char'175} in -the document. The scope of the declaration will be from the point of introduction to -the end of the document. To cancel a redefinition, use {\tt \char'134 def} to -redefine it back to what it was originally. The different typefaces available in \LaTeX\ are -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 bf} & {\bf Boldface} \\ -{\tt \char'134 em} & {\em Emphatic\/} \\ -{\tt \char'134 it} & {\it Italics\/} \\ -{\tt \char'134 rm} & {\rm Roman} \\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 sc} & {\sc Small Caps} \\ -{\tt \char'134 sf} & {\sf Sans Serif} \\ -{\tt \char'134 sl} & {\sl Slanted\/} \\ -{\tt \char'134 tt} & {\tt Typewriter} \\ \hline -\end{tabular} -\end{center} -It should be noted that the emphatic typeface is just the same as italics, although -nesting emphatic sections will alternate between italics and roman. - -Two types of quote mark are redefinable, forwards quotes and escape quotes. -The default for both of them is ' but if it is wished to redefine one or -both of them, use the {\tt \char'134 def} with either {\tt \char'134 forquo} -or {\tt \char'134 escquo}. For example, to make escape quotes be -printed as {\sf '} use {\tt \char'134 def\char'134 escquo\char'173 \char'134 hbox\char'173 \char'134 sf '\char'175 \char'175} in the document. - -\subsect{Altering the output} - -As {\tt pphs} produces code which is subsequently run through \LaTeX , it is possible -to alter the code before it is run through \LaTeX . This is useful for correcting -mistakes made by {\tt pphs}. However, it is recommended that only those experienced -in \LaTeX\ try this.
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/User_Documents.tex b/ghc/CONTRIB/pphs/docs/User_Documents.tex deleted file mode 100644 index 0680e62daf..0000000000 --- a/ghc/CONTRIB/pphs/docs/User_Documents.tex +++ /dev/null @@ -1,5 +0,0 @@ -\chapter{User documentation} - -This document is intended to be read by users of {\tt pphs}. - -\input{UserGuide_Text} diff --git a/ghc/CONTRIB/pphs/docs/Uses.tex b/ghc/CONTRIB/pphs/docs/Uses.tex deleted file mode 100644 index c488bb4263..0000000000 --- a/ghc/CONTRIB/pphs/docs/Uses.tex +++ /dev/null @@ -1,262 +0,0 @@ -\chapter{Uses for output} - -This chapter describes how the output from {\tt pphs} can be used. First, -examples of the capabilities of {\tt pphs} are shown, then it is explained how -the output is incorporated into \LaTeX\ documents, and how the user can alter -the output using built in methods or by editing the output. - -\section{Examples of output} \label{examples} - -Up until now, only examples of input have been shown. Let us now see what -{\tt pphs} actually does to this input. Take this earlier example. -\begin{quote} -\input{Haskell_leftindent2} -\end{quote} -This is how this code is typeset by {\tt pphs}. -\begin{quote} -\input{LaTeX_leftindent2} -\end{quote} -Probably the most obvious thing about the typeset code is the highlighting -of the identifiers. The reserved identifier or keyword {\keyword where} has been -highlighted in boldface while all the other identifiers are in italics. -The various symbols are in roman or math font as appropriate, these do not -get put in italics. Less obvious is the indentation. Notice how the starts -of the third, fourth and sixth lines all line up under {\iden state\/} on the -second line, just like they do in the input. Similarly, the start of the fifth -line is under the $|$ on the fourth. This demonstrates {\tt pphs}'s ability to -recreate left indentation in \LaTeX. But note how the $=$ on the sixth line does -not align under the $|$ on the fifth as it does in the input. This is because -they are different characters and so {\tt pphs} does not recognise this as internal -alignment. The only special case made in this part of the program was for $::$ and $=$. -Alignment would have occurred by coincidence had the preceding characters on both lines -been of the same width. - -To illustrate internal alignment, recall this earlier example. -\begin{quote} -\input{Haskell_internalalign1} -\end{quote} -This code gets typeset like this. -\begin{quote} -\input{LaTeX_internalalign1} -\end{quote} -Notice here how the $=$ signs are aligned in a column, despite being preceded -be characters that may be of different widths. This demonstrates the ability of -{\tt pphs} to recreate internal alignment. Notice also how the {\tt '} signs -have been interpreted as primes. This is because they are immediately preceded -by identifiers. The {\tt *} signs have been transformed into multiplication signs, -while the {\tt =>} has been replaced with $\Rightarrow$. - -Here is a new example, this time illustrating a comment and strings. -\begin{quote} -\input{Haskell_string1} -\end{quote} -This example gets typeset as follows. -\begin{quote} -\input{LaTeX_string1} -\end{quote} -Note how {\tt pphs} puts the correct inverted commas at each end of the strings -and how the strings themselves and the comment are in roman typeface. -The $=$ signs show internal alignment. - -This next example demonstrates a comment, character quotes and the special case -with internal alignment where {\tt =} are aligned under {\tt ::}. -\begin{quote} -\input{Haskell_char} -\end{quote} -Typeset, this becomes -\begin{quote} -\input{LaTeX_char} -\end{quote} -The comment is typeset in roman, as are the character quotes. This example has -the default double colon. Using the {\tt -w} option, the colons can be positioned -further apart as illustrated below. -\begin{quote} -\input{LaTeX_wide-colons} -\end{quote} -It is a matter of taste which is used. - -\section{Incorporating output into \LaTeX\ documents} - -The motivation behind typesetting Haskell programs was so they could be incorporated -into \LaTeX\ documents. This section describes how to do this with the output -of {\tt pphs}. - -\subsection{The style file} \label{style-file} - -Before using the output generated by {\tt pphs}, it is necessary to incorporate the -{\tt pphs.sty} style file (see Appendix~\ref{style-code}) into the document. -This provides definitions of the non-standard -commands produced by the program. The use of the style file is announced -by adding {\tt pphs} to the option list of the documentstyle -command like thus: -\begin{quote} -\begin{verbatim} -\documentstyle[12pt,a4,pphs]{article} -\end{verbatim} -\end{quote} -Without {\tt pphs} in the option list, errors will occur when \LaTeX\ is run, -unless all the non-standard commands used by {\tt pphs} have been defined elsewhere -in the document. - -\subsection{Including the output file} - -To include the file containing the code output by {\tt pphs}, the \LaTeX\ -{\tt \char'134 input} command is used. If the file containing the output is called -{\tt output.tex} then the following command is used. -\begin{quote} -\begin{verbatim} -\input{output} -\end{verbatim} -\end{quote} -The code will appear at the left margin like this: -\input{LaTeX_simple} -This is useful for code listings. - -By using various different \LaTeX\ environments, the typeset Haskell code -can be arranged differently. -To have the code indented like the examples in Section~\ref{examples}, the -{\tt quote} environment should be used. The code -\begin{quote} -\begin{verbatim} -\begin{quote} -\input{output} -\end{quote} -\end{verbatim} -\end{quote} -would produce -\begin{quote} -\input{LaTeX_simple} -\end{quote} -The {\tt table} environment can be used to put the typeset Haskell code -into a table and also allows the code to be captioned. -The table will appear at the top of the current or next page depending on what -space is available in the document. The \LaTeX\ code used to produce this is -\begin{quote} -\begin{verbatim} -\begin{table} -\begin{center} -\begin{minipage}{5cm} -\input{output} -\end{minipage} -\end{center} -\caption{Typeset code in a table} \label{output-table} -\end{table} -\end{verbatim} -\end{quote} -and this will produce a table, in this case Table~\ref{simple-table}. -The {\tt minipage} environment is required because \LaTeX\ interprets the {\tt tabbing} -environment as occupying the full page width, even if the text doesn't actually -use all that space. The width argument, here {\tt 5cm}, is set to the width of the typeset -Haskell code. If centering is not required, omit the {\tt center} and -{\tt minipage} environments. -The table can be referenced if it is labelled with the {\tt \char'134 label} -command, as above, and can be referred to in the text by using the code -{\tt Table\char'176 \char'134 ref\char'173 output-table\char'175} which will -keep the table number consistent with the numbering of the chapter and other tables. -\begin{table} -\begin{center} -\begin{minipage}{5cm} -\input{LaTeX_simple} -\end{minipage} -\end{center} -\caption{Typeset code in a table} \label{simple-table} -\end{table} -Similarly, the {\tt figure} environment can be used. The code is -\begin{quote} -\begin{verbatim} -\begin{figure} -\begin{center} -\begin{minipage}{5cm} -\input{output} -\end{minipage} -\end{center} -\caption{Typeset code in a figure} \label{output-figure} -\end{figure} -\end{verbatim} -\end{quote} -which produces a figure, in this case Figure~\ref{simple-figure}. -Again, it can be captioned and referenced, as with tables. -\begin{figure} -\begin{center} -\begin{minipage}{5cm} -\input{LaTeX_simple} -\end{minipage} -\end{center} -\caption{Typeset code in a figure} \label{simple-figure} -\end{figure} - -The result, once included in the final document, may have too -much blank space under the typeset code such as is the case in -this next example. -\begin{quote} -\input{LaTeX_blankline} -\end{quote} -This means there were extra blank lines at the end of the input file, caused -by extra return characters. This can be -rectified by removing the extra return characters and running {\tt pphs} again. - -\subsection{Lengthy lines} - -It is always possible that the lines of typeset Haskell code will run off -the right-hand edge of the user's page in the final document. Where this happens, -it is necessary to edit the input file and re-run {\tt pphs}. Be careful not to -change the parse of the program by wrongly indenting the second part of the line. - -\section{User adjustments} \label{user-adj} - -The user is able to have some say on what the output looks like. -This makes the program more flexible and doesn't dictate what a -Haskell program should look like when typeset. There are two areas in which user -choice is allowed, other than the double colon symbol described in Chapter~\ref{wide-colons}. - -\subsection{Typefaces} - -The default settings for typefaces are bold for keywords, italics for identifiers and -roman for everything else that is not in the math typeface. However, keywords, identifiers, -strings, comments and numbers may be in whatever typeface the user chooses. -This is done using the {\tt \char'134 def} command to redefine the typeface commands -used by {\tt pphs}. These are {\tt \char'134 keyword}, {\tt \char'134 iden}, -{\tt \char'134 stri}, {\tt \char'134 com} and {\tt \char'134 numb} respectively. - -For example, to put all comments into typewriter font, use -{\tt \char'134 def\char'134 com\char'173 \char'134 tt\char'175} in -the document. The scope of the declaration will be from the point of introduction to -the end of the document. To cancel a redefinition, use {\tt \char'134 def} to -redefine it back to what it was originally. - -The different typefaces available in \LaTeX\ are shown in Table~\ref{fonts}. -It should be noted that the emphatic typeface is just the same as italics, although -nesting emphatic sections will alternate between italics and roman. -\begin{table} -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 bf} & {\bf Boldface} \\ -{\tt \char'134 em} & {\em Emphatic\/} \\ -{\tt \char'134 it} & {\it Italics\/} \\ -{\tt \char'134 rm} & {\rm Roman} \\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 sc} & {\sc Small Caps} \\ -{\tt \char'134 sf} & {\sf Sans Serif} \\ -{\tt \char'134 sl} & {\sl Slanted\/} \\ -{\tt \char'134 tt} & {\tt Typewriter} \\ \hline -\end{tabular} -\end{center} -\caption{Typefaces available in \LaTeX } \label{fonts} -\end{table} - -\subsection{Quote marks} - -Two types of quote mark are redefinable, forwards quotes and escape quotes. -The default for both of them is ' but if it is wished to redefine one or -both of them, use the {\tt \char'134 def} with either {\tt \char'134 forquo} -or {\tt \char'134 escquo}. For example, to make escape quotes be -printed as {\sf '} use {\tt \char'134 def\char'134 escquo\char'173 \char'134 hbox\char'173 \char'134 sf '\char'175 \char'175} in the document. - -\section{Altering the output} - -As {\tt pphs} produces code which is subsequently run through \LaTeX , it is possible -to alter the code before it is run through \LaTeX . This is useful for correcting -mistakes made by {\tt pphs}. However, it is recommended that only those experienced -in \LaTeX\ try this.
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/What.tex b/ghc/CONTRIB/pphs/docs/What.tex deleted file mode 100644 index 741c822fa2..0000000000 --- a/ghc/CONTRIB/pphs/docs/What.tex +++ /dev/null @@ -1,136 +0,0 @@ -\chapter{What {\tt pphs} does} - -This chapter describes a program called {\tt pphs} which implements the typesetting -requirements described in the previous chapter. The description is from the user's viewpoint, -later chapters going on to describe it from that of the programmer. - -The {\tt pphs} program typesets Haskell programs for use with the \LaTeX\ -typesetting program. It takes as input a file containing a Haskell -program and produces the Haskell code to {\tt stdout}. It is called by -typing {\tt pphs}, followed by the name of the file containing the Haskell -program. For example, if the Haskell program was in a file called {\tt Haskell.hs}, -the program would be called by -\begin{quote} -\tt pphs Haskell.hs -\end{quote} - -If the filename ends with a {\tt .hs} extension, the extension may be omitted, provided -there is no file already existing with the same name but with no extension. If no -extension is given with the filename when called, the program will look for a file of -that name with no extension. If this is not found, the program will add a {\tt .hs} -extension. The above example, therefore, may be simplified to -\begin{quote} -\tt pphs Haskell -\end{quote} -unless the file {\tt Haskell} exists, in which case the original call must be made. - -As the output of {\tt pphs} is to {\tt stdout}, it may be directed to a file by using -the {\tt >} command after the call, followed by the name of the file to contain -the \LaTeX\ code. Continuing the above example, if the output code is to be put into -a file called {\tt Haskell.tex}, the call would now be -\begin{quote} -\tt pphs Haskell.hs > Haskell.tex -\end{quote} -It must be noted that if the file {\tt Haskell.tex} already exists, it should be -renamed or removed before making this call. - -Two options are allowed with the call. In the output, some people prefer \label{wide-colons} -the {\tt ::} symbol to be written $:\,:$ rather than $::$. To obtain the former, use -{\tt -w} for wide colons. A call on {\tt Haskell.hs} requiring wide colons would be -\begin{quote} -\tt pphs -w Haskell.hs -\end{quote} -When the input file's tab characters are not of the standard 8 spaces, this can be -specified with the {\tt -t} command. For example, if the tabs were 4 spaces long, type -\begin{quote} -\tt pphs -t4 Haskell.hs -\end{quote} -Both options can be used at the same time by calling -\begin{quote} -\tt pphs -t4w Haskell.hs -\end{quote} -or -\begin{quote} -\tt pphs -wt4 Haskell.hs -\end{quote} -Any positive integer can be specified for the tablength. - -\section{Left indentation} - -It is in the nature of Haskell programs that indentation is heavily used. As the -indentation is vital to the parsing of the program, any attempt at typesetting -Haskell code must replicate this indentation. Take, for example, the following piece of code. -\begin{quote} -\input{Haskell_leftindent1} -\end{quote} -Note how the third and fourth lines both start at different levels of indentation. -The {\tt pphs} program produces the correct \LaTeX\ code to align these under the -correct position in the preceding lines once typeset. It also selects the correct -line to line up under. Note how, in the following example, the sixth line does not line up -under its predecessor, but under the fourth line. -\begin{quote} -\input{Haskell_leftindent2} -\end{quote} -Again, {\tt pphs} produces the code necessary to typeset this, preserving the parsing -order. A line of Haskell code may be indented beyond the end of its predecessor. -Here, {\tt pphs} aligns it with whichever line it is lined up underneath in the -original file. Note that these -examples of possible input have no `extra' typesetting commands. - -\section{Internal alignment} - -Another form of alignment used in Haskell is {\em internal alignment}. This is where -there is vertical alignment of columns other than at the left-hand edge of the -Haskell code. -\begin{quote} -\input{Haskell_internalalign1} -\end{quote} -In this example, see how the {\tt =} signs line up, one below the other. This makes -the program more readable, although it does not affect the parsing of the program. -As the purpose of {\tt pphs} is to make Haskell programs even more readable, it -retains this alignment. - -\section{Token highlighting} - -To increase the readability of Haskell programs, {\tt pphs} allows various tokens -to be highlighted. By using different typefaces for some pieces of code, this -distinguishes them from the rest. The user can specify the details of the highlighting as -described in Section~\ref{user-adj}, but the default settings are {\bf bold} for -keywords, {\it italics} for identifiers and {\rm roman} for everything else. Strings, -comments and numbers are also highlightable (see Section~\ref{user-adj}). - -\section{Mathematical symbols} - -Rather than simply replicate the ASCII approximations of mathematical symbols -used in Haskell, {\tt pphs} -substitutes the proper symbols in the output. These are shown in Table~\ref{maths-sym}. -\begin{table} -\begin{center} -\begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt *} & $\times$ \\ -{\tt ++} & {\hbox{$+\mkern-7.5mu+$}} \\ -{\tt :+} & {:}{+} \\ -{\tt <=} & $\leq$ \\ \hline -\end{tabular} \hskip3mm \begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt >=} & $\geq$ \\ -{\tt <-} & $\leftarrow$ \\ -{\tt ->} & $\rightarrow$ \\ -{\tt =>} & $\Rightarrow$ \\ \hline -\end{tabular} -\end{center} -\caption{Haskell ASCII approximations to mathematical characters} \label{maths-sym} -\end{table} - -\section{\LaTeX\ typesetting characters} - -\LaTeX\ uses embedded typesetting commands, so {\tt pphs} has to ensure that if -any of the characters used by \LaTeX\ appear in the input Haskell code, the correct -\LaTeX\ code is outputted to typeset them, rather than have the characters interfere -with the typesetting process. The characters used by \LaTeX\ for typesetting are: -\begin{quote} -\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) -\end{quote} -The user of {\tt pphs} need not worry about using any of these characters in Haskell -programs, as this will be dealt with by {\tt pphs} before \LaTeX\ gets to see the code.
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Wrapper.tex b/ghc/CONTRIB/pphs/docs/Wrapper.tex deleted file mode 100644 index c780cd8be6..0000000000 --- a/ghc/CONTRIB/pphs/docs/Wrapper.tex +++ /dev/null @@ -1,6 +0,0 @@ -\documentstyle[12pt,fleqn,a4,pphs]{article} -\begin{document} - -\input{Haskell} - -\end{document} diff --git a/ghc/CONTRIB/pphs/docs/char.hs b/ghc/CONTRIB/pphs/docs/char.hs deleted file mode 100644 index 0aa661eab7..0000000000 --- a/ghc/CONTRIB/pphs/docs/char.hs +++ /dev/null @@ -1,5 +0,0 @@ --- Character functions - -minChar, maxChar :: Char -minChar = '\0' -maxChar = '\255'
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/comment.hs b/ghc/CONTRIB/pphs/docs/comment.hs deleted file mode 100644 index 694cc4aa2c..0000000000 --- a/ghc/CONTRIB/pphs/docs/comment.hs +++ /dev/null @@ -1 +0,0 @@ --- note that x + y = z
\ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/internalalign1.hs b/ghc/CONTRIB/pphs/docs/internalalign1.hs deleted file mode 100644 index dad2f142b0..0000000000 --- a/ghc/CONTRIB/pphs/docs/internalalign1.hs +++ /dev/null @@ -1,9 +0,0 @@ -instance (RealFloat a) => Num (Complex a) where - (x:+y) + (x':+y') = (x+x') :+ (y+y') - (x:+y) - (x':+y') = (x-x') :+ (y-y') - (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') - negate (x:+y) = negate x :+ negate y - abs z = magnitude z :+ 0 - signum 0 = 0 - signum z@(x:+y) = x/r :+ y/r where r = magnitude z - fromInteger n = fromInteger n :+ 0 diff --git a/ghc/CONTRIB/pphs/docs/leftindent1.hs b/ghc/CONTRIB/pphs/docs/leftindent1.hs deleted file mode 100644 index 43a7cf44ed..0000000000 --- a/ghc/CONTRIB/pphs/docs/leftindent1.hs +++ /dev/null @@ -1,4 +0,0 @@ -gcd :: Int -> Int -> Int -gcd x y = gcd' (abs x) (abs y) - where gcd' x 0 = x - gcd' x y = gcd' y (x `rem` y) diff --git a/ghc/CONTRIB/pphs/docs/leftindent2.hs b/ghc/CONTRIB/pphs/docs/leftindent2.hs deleted file mode 100644 index 9d9fcd07c1..0000000000 --- a/ghc/CONTRIB/pphs/docs/leftindent2.hs +++ /dev/null @@ -1,6 +0,0 @@ -eval :: GmState -> [GmState] -eval state = state: restStates - where - restStates | gmFinal state = [] - | otherwise = eval nextState - nextState = doAdmin (step state) diff --git a/ghc/CONTRIB/pphs/docs/math.hs b/ghc/CONTRIB/pphs/docs/math.hs deleted file mode 100644 index 4906527797..0000000000 --- a/ghc/CONTRIB/pphs/docs/math.hs +++ /dev/null @@ -1,3 +0,0 @@ --- list concatenation (right-associative) -(++) :: [a] -> [a] -> [a] -xs ++ ys = foldr (:) ys xs diff --git a/ghc/CONTRIB/pphs/docs/pphs.sty b/ghc/CONTRIB/pphs/docs/pphs.sty deleted file mode 100644 index 298a58ea78..0000000000 --- a/ghc/CONTRIB/pphs/docs/pphs.sty +++ /dev/null @@ -1,26 +0,0 @@ -% ========================================= -% Definitions for use with the pphs program -% ========================================= - -\typeout{For use with the pphs program} - -% Definitions of commands used by pphs - -\newbox\foo -\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo} -\def\plusplus{\hbox{$+\mkern-7.5mu+$}} -\def\xspa#1{\hskip#1ex} -\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}} - -% User-redefinable commands - typefaces - -\def\keyword{\bf} -\def\iden{\it} -\def\stri{\rm} -\def\com{\rm} -\def\numb{\rm} - -% User-redefinable commands - quote marks - -\def\forquo{\hbox{\rm '}} -\def\escquo{\hbox{\rm '}} diff --git a/ghc/CONTRIB/pphs/docs/rep.sty b/ghc/CONTRIB/pphs/docs/rep.sty deleted file mode 100644 index bb4242d7a4..0000000000 --- a/ghc/CONTRIB/pphs/docs/rep.sty +++ /dev/null @@ -1,80 +0,0 @@ -% ===================================================================== -% A4 layout file for documents with big left margins - for folders. -% ===================================================================== - -\typeout{A4 with big left margin document layout} - -% --------------------------------------------------------------------- -% make "@" a letter -% --------------------------------------------------------------------- -\makeatletter - -% --------------------------------------------------------------------- -% PAPER SIZE -% -% TeX expects 1 inch margins all around (1 inch = 25.4 mm). -% a4 is exactly 297mm high by 208mm wide. -% --------------------------------------------------------------------- - -\hsize=157.2truemm -\vsize=246.2truemm - -% --------------------------------------------------------------------- -% PAGE LAYOUT -% -% text size = 144.5mm wide by 231.1mm high -% -% Top Margin: 1in -% Left margin: 1.5in -% Right Margin: 1in -% --------------------------------------------------------------------- - -\textwidth 144.5truemm -\textheight 231.1truemm - -\oddsidemargin=12.7truemm -\evensidemargin=0truemm -\topmargin=0truemm - -% --------------------------------------------------------------------- -% RUNNING HEAD: none -% --------------------------------------------------------------------- -\headheight 0mm -\headsep 0mm - -% --------------------------------------------------------------------- -% FOOT: page number and other information. -% --------------------------------------------------------------------- -\footheight 12pt -\footskip 18truemm -\addtolength{\footskip}{\footheight} - -% --------------------------------------------------------------------- -% INDENTATION -% -% 5mm indentation -% --------------------------------------------------------------------- -\parindent 5truemm - -% --------------------------------------------------------------------- -% math indentation. -% --------------------------------------------------------------------- -\mathindent 10.0truemm - -% --------------------------------------------------------------------- -% FOOTNOTES -% -% Footnotes are in 10 point font. -% -% put 12+1-1 points between text and rule -% put 10pt between at start of footnote -% foot note rule 40mm long -% --------------------------------------------------------------------- -\skip\footins 12pt plus 2pt minus 2pt -\footnotesep 10pt -\def\footnoterule{\kern-3\p@ \hrule width 40mm \kern 2.6\p@} - -% --------------------------------------------------------------------- -% make "@" an other -% --------------------------------------------------------------------- -\makeatother diff --git a/ghc/CONTRIB/pphs/docs/simple.hs b/ghc/CONTRIB/pphs/docs/simple.hs deleted file mode 100644 index b31d0232b6..0000000000 --- a/ghc/CONTRIB/pphs/docs/simple.hs +++ /dev/null @@ -1,3 +0,0 @@ -foobar a b = c - where - c = a + b diff --git a/ghc/CONTRIB/pphs/docs/string1.hs b/ghc/CONTRIB/pphs/docs/string1.hs deleted file mode 100644 index 437573222c..0000000000 --- a/ghc/CONTRIB/pphs/docs/string1.hs +++ /dev/null @@ -1,6 +0,0 @@ --- File and channel names: - -stdin = "stdin" -stdout = "stdout" -stderr = "stderr" -stdecho = "stdecho" diff --git a/ghc/CONTRIB/pphs/docs/string2.hs b/ghc/CONTRIB/pphs/docs/string2.hs deleted file mode 100644 index c3a063756b..0000000000 --- a/ghc/CONTRIB/pphs/docs/string2.hs +++ /dev/null @@ -1,8 +0,0 @@ -main = appendChan stdout "please type a filename\n" exit ( - readChan stdin exit (\ userInput -> - let (name : _) = lines userInput in - appendChan stdout name exit ( - readFile name (\ ioerror -> appendChan stdout - "can't open file" exit done) - (\ contents -> - appendChan stdout contents exit done)))) diff --git a/ghc/CONTRIB/pphs/pphs.c b/ghc/CONTRIB/pphs/pphs.c deleted file mode 100644 index aa31a3e7bd..0000000000 --- a/ghc/CONTRIB/pphs/pphs.c +++ /dev/null @@ -1,1030 +0,0 @@ - /* pphs - a pretty printer for Haskell code */ -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#define MAXLINELENGTH 256 - -enum face {KW, ID, IS, SU, ST, CO, NU, MA, SP, LC, RC, CR, BF, FQ, EQ, DQ, QD, EE, DC, DP, CP, LE, GE, LA, RA, RR, TI, BE}; - /* Possible values of typeface */ - -int widecolons = 0; /* User may want space between double colons */ -int subscripts = 0; /* User may want subscripts after '_' in identifiers */ -int tablength = 8; /* User's input file tablength */ - -typedef struct ElementType_Tag { /* Basic storage unit */ - char chars[MAXLINELENGTH]; /* Characters */ - enum face typeface[MAXLINELENGTH]; /* Typefaces */ - int indentation, length, col; /* Indentation level, non-empty length, column level */ -} ElementType; - -typedef struct StackNodeType_Tag *Link; /* Stack-related types */ -typedef struct StackNodeType_Tag { - ElementType Element; /* Stack item */ - Link Next; /* Link to next node */ -} StackNodeType; -typedef StackNodeType *StackNodePtr; -typedef StackNodePtr StackType; - -typedef int QueueSizeType; /* Queue-related types */ -typedef struct QueueNodeType_Tag *Connection; -typedef struct QueueNodeType_Tag { - ElementType Element; /* Queue item */ - Connection Next; /* Link to next node */ -} QueueNodeType; -typedef QueueNodeType *QueueNodePtr; -typedef struct QueueType_Tag { - QueueNodePtr Front, Rear; - QueueSizeType Length; -} QueueType; - -FILE *ifptr; /* input file pointer */ - - /* * * STACK FUNCTIONS * * */ -StackType - CreateStack() /* Returns an empty stack */ -{ - return(NULL); -} - -int - IsEmptyStack(s) /* Returns 1 if s is empty, 0 otherwise */ -StackType s; -{ - return(s == NULL); -} - -StackType - Push(s, x) /* Returns stack with x pushed onto s */ -StackType s; -ElementType x; -{ - StackType p; - - p = (StackNodeType *) malloc(sizeof(StackNodeType)); - if (p == NULL) { - fprintf(stderr, "pphs: Stack is too big\n"); - exit(3); - } - else { - (*p).Element = x; - (*p).Next = s; - return(p); - } -} - -ElementType - Top(s) /* Returns value of top element in s */ -StackType s; -{ - return((*s).Element); -} - -StackType - Pop(s) /* Returns stack with top element of s popped off */ -StackType s; -{ - StackType t; - - t = (*s).Next; - free(s); - return(t); -} - -StackType - PopSym(s) /* Returns stack with top element of s popped off without freeing */ -StackType s; -{ - StackType t; - - t = (*s).Next; -/* free(s); As PopSym is called within a function, free would free space needed later */ - return(t); -} - /* * * QUEUE FUNCTIONS * * */ -QueueType - CreateQueue() /* Returns an empty queue */ -{ - QueueType q; - - q.Front = NULL; - q.Rear = NULL; - q.Length = 0; - return(q); -} - -int - IsEmptyQueue(q) /* Returns 1 if q is empty, 0 otherwise */ -QueueType q; -{ - return(q.Front == NULL); -} - -int - LengthOfQueue(q) /* Returns length of q */ -QueueType q; -{ - return(q.Length); -} - -QueueNodePtr - FrontOfQueue(q) /* Returns pointer to front of q */ -QueueType q; -{ - return(q.Front); -} - -QueueNodePtr - RearOfQueue(q) /* Returns pointer to rear of q */ -QueueType q; -{ - return(q.Rear); -} - -QueueType - AddToQueue(q, x) /* Adds item x to rear of queue q */ -QueueType q; -ElementType x; -{ - QueueNodePtr p; - - p = (QueueNodeType *) malloc(sizeof(QueueNodeType)); - if (p == NULL) { - fprintf(stderr, "pphs: Queue is too big\n"); - exit(4); - } - else { - (*p).Element = x; - (*p).Next = NULL; - if (q.Front == NULL) - q.Front = p; - else - (*(q.Rear)).Next = p; - q.Rear = p; - q.Length++; - return(q); - } -} - -QueueType - TakeFromQueue(q) /* Removes front item from queue */ -QueueType q; -{ - QueueNodePtr p; - - if (q.Front == NULL) { - fprintf(stderr, "pphs: Stack underflow\n"); - exit(5); - } - else { - p = q.Front; - q.Front = (*(q.Front)).Next; - if (q.Front == NULL) - q.Rear = NULL; - q.Length--; - free(p); - return(q); - } -} - /* * * TYPEFACE FUNCTIONS * * */ -int - IsMathsChar(c) /* Returns 1 if c is a character to be in maths */ -char c; -{ - return((c == '[') || (c == ']') || (c == '/') || (c == ',') || (c == '!') - || (c == ':') || (c == ';') || (c == '(') || (c == ')') || (c == '&') - || (c == '#') || (c == '+') || (c == '-') || (c == '<') || (c == '>') - || (c == '{') || (c == '}') || (c == '=') || (c == '|') || (c == '\'') - || (c == '^')); -} - -ElementType - ChangeTypeface(store, length, finish, tf) /* Changes the typeface to tf in store - for length until finish */ -ElementType store; -int length, finish; -enum face tf; -{ - int counter; - - for (counter = (finish - length); counter < finish; counter++) - store.typeface[counter] = tf; - return(store); -} - -ElementType - CheckForDoubleChar(store, position) /* Checks for double character - in store.chars[position - 2..position - 1], - if found alters typeface */ -ElementType store; -int position; -{ - if ((position >= 2) && (store.typeface[position - 2] != DC)) { - if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '-')) { - store.typeface[position - 2] = LC; /* Haskell "--" line comment */ - store.typeface[position - 1] = LC; - } - else if ((store.chars[position - 2] == '{') && (store.chars[position - 1] == '-')) { - store.typeface[position - 2] = RC; /* Haskell "{-" regional comment begin */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '}')) { - store.typeface[position - 2] = CR; /* Haskell "-}" regional comment end */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '+') && (store.chars[position - 1] == '+')) { - store.typeface[position - 2] = DP; /* Double plus */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == ':') && (store.chars[position - 1] == '+')) { - store.typeface[position - 2] = CP; /* Colon plus */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '<') && (store.chars[position - 1] == '=')) { - store.typeface[position - 2] = LE; /* Less than or equal to */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '>') && (store.chars[position - 1] == '=')) { - store.typeface[position - 2] = GE; /* Greater than or equal to */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '<') && (store.chars[position - 1] == '-')) { - store.typeface[position - 2] = LA; /* Leftarrow */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '>')) { - store.typeface[position - 2] = RA; /* Rightarrow */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '=') && (store.chars[position - 1] == '>')) { - store.typeface[position - 2] = RR; /* Double rightarrow */ - store.typeface[position - 1] = DC; - } - else if (((store.chars[position - 2] == '*') && (store.chars[position - 1] == '*')) - || ((store.chars[position - 2] == '^') && (store.chars[position - 1] == '^'))) { - store.typeface[position - 2] = MA; /* Exponent, ie not Times */ - store.typeface[position - 1] = MA; - } - } - return(store); -} - -int - IsHaskellPunc(c) /* Returns 1 if c is a punctuation mark not part of identifier */ -char c; -{ - return((c == ' ') || (c == ',') || (c == '@') || (c == '#') || (c == '$') - || (c == '%') || (c == '&') || (c == '*') || (c == '(') || (c == ')') - || (c == '-') || (c == '+') || (c == '=') || (c == '\\') || (c == '|') - || (c == '[') || (c == ']') || (c == '{') || (c == '}') || (c == ':') - || (c == ';') || (c == '"') || (c == '~') || (c == '?') || (c == '/') - || (c == '<') || (c == '>') || (c == '^')); -} - -int - IsKeyWord(str) /* Returns 1 if str is a keyword to be in keyword font */ -char str[MAXLINELENGTH]; -{ - return((!(strcmp(str, "case"))) || (!(strcmp(str, "class"))) - || (!(strcmp(str, "data"))) || (!(strcmp(str, "default"))) - || (!(strcmp(str, "deriving"))) || (!(strcmp(str, "else"))) - || (!(strcmp(str, "hiding"))) || (!(strcmp(str, "if"))) - || (!(strcmp(str, "import"))) || (!(strcmp(str, "in"))) - || (!(strcmp(str, "infix"))) || (!(strcmp(str, "infixl"))) - || (!(strcmp(str, "infixr"))) || (!(strcmp(str, "instance"))) - || (!(strcmp(str, "interface"))) || (!(strcmp(str, "let"))) - || (!(strcmp(str, "module"))) || (!(strcmp(str, "of"))) - || (!(strcmp(str, "renaming"))) || (!(strcmp(str, "then"))) - || (!(strcmp(str, "to"))) || (!(strcmp(str, "type"))) - || (!(strcmp(str, "where")))); -} - -int - KeyWord(c, store, position) /* Returns length of keyword if a keyword ends - at store.chars[position - 1] */ -char c; -ElementType store; -int position; -{ - int counter, start, end = position - 1, keywordlen = 0; - char str[MAXLINELENGTH]; - - if ((!isalpha(c)) && (c != '_') && (c != '\'') && (position)) { - for (counter = end; (counter >= 0) && ((isalpha(store.chars[counter])) - || (c == '_') || (c == '\'')) - && (counter >= store.indentation); counter--) { - ; /* Just count letters */ - } - start = ++counter; - for (counter = 0; counter + start <= end; counter++) { - str[counter] = store.chars[counter + start]; /* Copy letters into str */ - } - str[counter] = '\0'; /* Add null character to end */ - if (IsKeyWord(str)) /* Checks word in str is keyword */ - keywordlen = strlen(str); /* and measures it */ - } - return(keywordlen); -} - -ElementType - CheckForKeyword(c, store, position) /* Returns store with any possible keyword - ending at store.chars[position - 1] - identified as such in store.typeface */ -char c; -ElementType store; -int position; -{ - if (KeyWord(c, store, position)) - store = ChangeTypeface(store, KeyWord(c, store, position), position, KW); - return(store); -} - -int - IsNumber(c, store, position, statesok) /* Returns 1 if c forms part of a number */ -char c; -ElementType store; -int position, statesok; -{ - int counter, foundident = 0, foundpunc = 0; - - if (((isdigit(c)) || (c == 'e') || (c == 'E') || (c == '|') || (c == '.')) - && (statesok)) { - counter = position - 1; - while ((isdigit(store.chars[counter])) && (counter >= 0)) - counter--; - if (((store.chars[counter] == '+') || (store.chars[counter] == '-')) - && ((store.chars[counter - 1] == 'e') || (store.chars[counter - 1] == 'E')) - && (counter > 2)) - counter -= 2; - else if (((store.chars[counter] == 'e') || (store.chars[counter] == 'E')) - && (counter > 1)) - counter--; - while ((isdigit(store.chars[counter])) && (counter >= 0)) - counter--; - if ((store.chars[counter] == '.') && (counter > 1)) - counter--; - while ((isdigit(store.chars[counter])) && (counter >= 0)) - counter--; - if ((isalpha(store.chars[counter])) && (counter >= 0)) - foundident = 1; /* ie not number */ - else if ((IsHaskellPunc(store.chars[counter])) || (counter < 0)) - foundpunc = 1; /* ie is number */ - } - return(foundpunc); -} - /* * * LINE SELECTION FUNCTIONS * * */ -ElementType - SelectSkipLine(s, store, linecounter) /* Returns store containing line for skipover */ -StackType s; -ElementType store; -int linecounter; -{ - ElementType temp; - int counter; - - if (!(IsEmptyStack(s))) { - while (((Top(s)).length <= linecounter) || ((Top(s)).indentation >= linecounter)) { - temp = Top(s); - s = PopSym(s); - if (IsEmptyStack(s)) { - counter = temp.length; - while (counter < linecounter) { - temp.chars[counter] = ' '; - temp.typeface[counter++] = SP; - } - temp.chars[counter] = '\0'; /* Add null character to end */ - s = Push(s, temp); - break; - } - } - store = Top(s); - } - else { /* Stack is empty */ - counter = store.length; - while (counter < linecounter) { - store.chars[counter] = ' '; - store.typeface[counter++] = SP; - } - store.chars[counter] = '\0'; /* Add null character to end */ - } - return(store); -} - /* * * STORING FUNCTIONS * * */ -ElementType - CreateStore() /* Returns an empty store */ -{ - ElementType store; - - strcpy(store.chars, ""); - store.length = 0; - store.indentation = 0; - store.col = 0; - return(store); -} - -ElementType - StoreSpace(store, position) /* Stores a space in the store at current position */ -ElementType store; -int position; -{ - store.chars[position] = ' '; - store.typeface[position] = SP; - return(store); -} - /* * * WRITING FUNCTIONS * * */ -void - WriteStartFace(tf) /* Writes LaTeX typeface commands for start of section */ -enum face tf; -{ - if (tf == KW) /* Keywords */ - printf("{\\keyword "); - else if ((tf == ID) || (tf == IS)) /* Identifiers */ - printf("{\\iden "); - else if (tf == ST) /* Strings */ - printf("{\\stri "); - else if (tf == CO) /* Comments */ - printf("{\\com "); - else if (tf == NU) /* Numbers */ - printf("{\\numb "); - else if ((tf == MA) || (tf == TI)) /* Various maths */ - printf("$"); -} - -void - WriteFinishFace(tf) /* Writes LaTeX typeface commands for end of section */ -enum face tf; -{ - if ((tf == KW) || (tf == ID) || (tf == ST) || (tf == CO) - || (tf == NU)) /* Keywords, identifiers, strings, comments or numbers */ - printf("\\/}"); - else if ((tf == MA) || (tf == TI)) /* Various maths */ - printf("$"); - else if (tf == IS) /* Subscripts in identifiers */ - printf("\\/}$"); -} - -int - WriteSpaces(store, counter, finish) /* Writes consecutive spaces, - returning new counter value */ -ElementType store; -int counter, finish; -{ - int spaces = 0; /* The number of spaces found */ - - for (; (store.typeface[counter] == SP) && (counter < finish); counter++) - spaces++; - printf("\\xspa{%d}", spaces); - return(--counter); -} - -int - WriteChar(store, counter, finish) /* Writes charater, returning new counter value */ -ElementType store; -int counter, finish; -{ - if (store.typeface[counter] == SP) /* Space */ - printf("\\xspa1"); /* Redundant */ - else if (store.typeface[counter] == BE) /* Bar under equals sign */ - printf("\\bareq"); - else if (store.typeface[counter] == DP) { /* Double plus */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("\\plusplus"); - counter++; - } - } - else if (store.typeface[counter] == CP) { /* Colon plus */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("{:}{+}"); - counter++; - } - } - else if (store.typeface[counter] == LE) { /* Less than or equal to */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\leq$"); - counter++; - } - } - else if (store.typeface[counter] == GE) { /* Greater than or equal to */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\geq$"); - counter++; - } - } - else if (store.typeface[counter] == LA) { /* Leftarrow */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\leftarrow$"); - counter++; - } - } - else if (store.typeface[counter] == RA) { /* Rightarrow */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\rightarrow$"); - counter++; - } - } - else if (store.typeface[counter] == RR) { /* Double rightarrow */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\Rightarrow$"); - counter++; - } - } - else if (store.typeface[counter] == RC) { /* Regional comment begin */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("{\\com \\{-\\/}"); - counter++; - } - else - printf("{\\com \\{\\/}"); - } - else if (store.typeface[counter] == CR) { /* Regional comment end */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("{\\com -\\}\\/}"); - counter++; - } - else - printf("{\\com -\\/}"); - } - else if ((store.typeface[counter] == LC) && (store.chars[counter] == '-')) - printf("{\\rm -}"); /* Comment - problem: "--" becomes "-" in LaTeX so fix done */ - else if (store.chars[counter] == '\\') - printf("\\hbox{$\\setminus$}"); /* Backslash */ - else if (store.chars[counter] == '*') { - if (store.typeface[counter] == TI) - printf("\\times "); /* Multiplication */ - else - printf("*"); /* Other star symbols, eg Exponent */ - } - else if ((store.chars[counter] == '_') && (store.typeface[counter] == SU)) { - if ((counter < finish - 1) && (store.typeface[counter + 1] == IS)) - printf("$_"); /* Subscript character */ - } - else if (store.chars[counter] == '^') - printf("\\char'136 "); /* Up-arrow */ - else if (store.chars[counter] == '~') - printf("\\char'176 "); /* Tilda */ - else if ((store.chars[counter] == ':') && (store.chars[counter - 1] == ':') - && (widecolons)) - printf("\\,:"); /* Double colon */ - else if (store.chars[counter] == '"') { - if ((counter) && ((store.chars[counter - 1] == '"') - || (store.chars[counter - 1] == '\''))) - printf("\\,"); /* If previous character was a quote, leave a little space */ - if (store.typeface[counter] == DQ) - printf("{\\rm ``}"); /* Open doublequote */ - else if (store.typeface[counter] == QD) - printf("{\\rm \"}"); /* Close doublequote */ - else - printf("{\\rm \\char'175}"); /* Escape doublequote in string */ - } - else if (store.chars[counter] == '\'') { - if ((counter) && ((store.chars[counter - 1] == '"') - || ((store.chars[counter - 1] == '\'') - && ((store.typeface[counter - 1] != MA) - || (store.typeface[counter] != MA))))) - printf("\\,"); /* If previous character was a quote, leave a little space - except when it's a double prime */ - if (store.typeface[counter] == FQ) - printf("\\forquo "); /* Forward single quote */ - else if (store.typeface[counter] == EQ) - printf("\\escquo "); /* Escape single quote */ - else if (store.typeface[counter] == BF) { - if ((counter + 1 < store.length) && (store.typeface[counter + 1] == BF) - && (counter + 1 != store.indentation)) { - printf("{\\com \'\'\\/}"); /* Closing LaTeX style quote */ - counter++; - } - else - printf("{\\com \'\\/}"); /* Single quote following backquote in comment */ - } - else - printf("\'"); /* Prime */ - } - else if (store.chars[counter] == '{') - printf("\\hbox{$\\cal \\char'146$}"); /* Open curly bracket */ - else if (store.chars[counter] == '}') - printf("\\hbox{$\\cal \\char'147$}"); /* Close curly bracket */ - else if ((counter) && (store.chars[counter - 1] == '[') && (store.chars[counter] == ']')) - printf("\\,]"); /* Leave small gap between adjacent square brackets */ - else if ((store.chars[counter] == '$') || (store.chars[counter] == '%') - || (store.chars[counter] == '_') || (store.chars[counter] == '#') - || (store.chars[counter] == '&')) /* Various characters needing '\' for LaTeX */ - printf("\\%c", store.chars[counter]); - else /* Other characters */ - printf("%c", store.chars[counter]); - return(counter); -} - -void - WriteSkipover(store) /* Writes the skipover portion of line in store */ -ElementType store; -{ - int counter = 0; - - printf("\\skipover{"); /* Write opening LaTeX skipover command */ - WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.indentation); /* Write spaces */ - else - counter = WriteChar(store, counter, store.indentation); /* Write character */ - for (counter++; counter < store.indentation; counter++){ /* until end of skipover */ - if (store.typeface[counter - 1] != store.typeface[counter]) { /* If typeface change */ - WriteFinishFace(store.typeface[counter - 1]); /* write closing typeface command */ - WriteStartFace(store.typeface[counter]); /* write opening LaTeX typeface command */ - } - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.indentation); /* Write spaces */ - else - counter = WriteChar(store, counter, store.indentation); /* Write character */ - } - if (store.typeface[counter - 1] == SU) - ; /* If indentation is under subscript don't open math section */ - else - WriteFinishFace(store.typeface[counter - 1]); /* Write closing LaTeX typeface command */ - printf("}"); /* Write closing LaTeX skipover command */ -} - -void - WriteWords(store) /* Writes rest of line, starting at indentation level */ -ElementType store; -{ - int counter = store.indentation; - int intabular = 0; /* Boolean: is in tabular section for internal alignment */ - - WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.length); /* Write spaces */ - else - counter = WriteChar(store, counter, store.length); /* Write character */ - for (counter++; counter < store.length; counter++){ /* until end of word */ - if ((store.col) && (store.col == counter)) { - printf(" & "); - if (store.chars[counter - 1] == ':') - printf("$:"); - intabular = 1; - } - if (store.typeface[counter - 1] != store.typeface[counter]) /* If typeface change */ - WriteFinishFace(store.typeface[counter - 1]); /* Write closing typeface command */ - if ((store.typeface[counter] == SP) && (intabular)) { - printf(" & "); - intabular = 0; - } - if ((store.typeface[counter - 1] != store.typeface[counter]) /* If typeface change */ - && ((store.chars[counter] != ':') || (store.col != counter + 1))) - WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.length); /* Write spaces */ - else if ((store.chars[counter] != ':') || (!store.col) || (store.col != counter + 1)) - counter = WriteChar(store, counter, store.length); /* Write character */ - } - WriteFinishFace(store.typeface[counter - 1]); /* Write closing LaTeX typeface command */ -} - -void - WriteLine(store, needed) /* Writes the line in store, - only writing LaTeX newline if needed */ -ElementType store; -int needed; -{ - if (store.indentation) - WriteSkipover(store); - if (store.indentation < store.length) - WriteWords(store); - if (needed) - printf("\\\\"); /* LaTeX newline character */ - printf("\n"); -} - -QueueType - WriteQueue(q) /* Writes lines, removing them from queue, - leaves last line in queue if not in tabular section */ -QueueType q; -{ - int intabular = 0; - - if ((!(IsEmptyQueue(q))) && ((*(FrontOfQueue(q))).Element.col)) { - printf("\\begin{tabular}{@{}l@{\\xspa1}c@{}l}\n"); - intabular = 1; - } - while (LengthOfQueue(q) > !intabular) { - WriteLine((*(FrontOfQueue(q))).Element, 1); /* LaTeX newline character is needed */ - q = TakeFromQueue(q); - } - if (intabular) - printf("\\end{tabular}\\\\\n"); - return(q); -} - -QueueType - WriteRestOfQueue(q) /* Writes all lines, removing them from queue, - doesn't have LaTeX newline after last line */ -QueueType q; -{ - int intabular = 0; - - if ((!(IsEmptyQueue(q))) && ((*(FrontOfQueue(q))).Element.col)) { - printf("\\begin{tabular}{@{}l@{\\xspa1}c@{}l}\n"); - intabular = 1; - } - while (!(IsEmptyQueue(q))) { - WriteLine((*(FrontOfQueue(q))).Element, (LengthOfQueue(q) > 1)); /* Last line doesn't - need LaTeX newline character */ - q = TakeFromQueue(q); - } - if (intabular) { - printf("\\end{tabular}"); - if (!IsEmptyQueue(q)) /* Last line doesn't need LaTeX newline character */ - printf("\\\\"); - printf("\n"); - } - return(q); -} - -int -main (argc, argv) /* * * MAIN PROGRAM * * */ - int argc; - char *argv[]; -{ - int tripped = 1, instring = 0, instringincomment = 0, inlinecomment = 0; - int incharquote = 0, incharquoteincomment = 0, inbackquoteincomment = 0; - int insub = 0; - /* Booleans - just taken new line, in string, in string inside comment, in line comment, - in character quote, in character quote inside comment, in backquote inside comment, - in subscript */ - int linecounter = 0, indentcounter = 0, inregcomment = 0, pos; - /* Counters: current position on line, indentation of current line, - nesting level of regional comments, position marker */ - char c; /* Character */ - StackType s; /* Stack of previous longest lines */ - QueueType q; /* Queue of lines waiting to be printed */ - ElementType store; /* Store of letters, typefaces and non-empty length */ - - if ((argc == 3) && (argv[1][0] == '-')) { /* If options specified with call */ - if (strstr(argv[1], "s")) /* if -s option, subscripts in identifiers wanted */ - subscripts = 1; - if (strstr(argv[1], "t")) { /* if -tX option, tab characters are X spaces */ - for (pos = 1; (argv[1][pos] != 't'); pos++) /* find 't' */ - ; - for (pos++, tablength = 0; isdigit(argv[1][pos]); pos++) /* read number */ - tablength = (tablength * 10) + (argv[1][pos] - '0'); - } - if (strstr(argv[1], "w")) /* if -w option called, wide double colons wanted */ - widecolons = 1; - } - else if (argc == 2) /* If no options */ - ; - else { /* If not called with pphs and a filename */ - fprintf(stderr, "pphs: Call with one file name\n"); - exit(1); - } - - if ((strcspn(argv[argc - 1], ".") == strlen(argv[argc - 1])) /* If filename has no extention */ - && ((ifptr = fopen(argv[argc - 1], "r")) == NULL)) /* and no plain file of that name */ - strcat(argv[argc - 1], ".hs"); /* add a ".hs" extention */ - if ((ifptr = fopen(argv[argc - 1], "r")) == NULL) { /* Open input file */ - fprintf(stderr, "pphs: File could not be opened\n"); /* eg isn't there */ - exit(2); - } - else { - - printf("\\begin{tabbing}\n"); /* Start of Haskell program */ - - store = CreateStore(); /* an empty one */ - s = CreateStack(); /* an empty one */ - q = CreateQueue(); /* an empty one */ - - fscanf(ifptr, "%c", &c); /* Read character */ - while (!feof(ifptr)) { /* While not at end of input file */ - while ((isspace(c)) && (!(feof(ifptr)))) { /* Read blank characters */ - if (c == ' ') { - if (tripped) - linecounter++; /* Count leading spaces */ - else { /* or */ - store = StoreSpace(store, linecounter++); /* Store intermediate - or trailing space */ - if (store.length < linecounter) - store.chars[linecounter] = '\0'; /* Add null character to end */ - } - fscanf(ifptr, "%c", &c); /* Read next character */ - } - else if (c == '\t') { - if (tripped) - linecounter += (tablength - (linecounter % tablength)); - else { - store = StoreSpace(store, linecounter++); - for (; linecounter % tablength; linecounter++) - store = StoreSpace(store, linecounter); - if (store.length < linecounter) - store.chars[linecounter] = '\0'; /* Add null character to end */ - } - fscanf(ifptr, "%c", &c); /* Read next character */ - } - else if (c == '\n') { - tripped = 1; /* Just taken a new line */ - inlinecomment = 0; - if (!(IsEmptyStack(s))) - while (((Top(s)).length <= store.length) - && ((Top(s)).indentation >= store.length)) { - s = Pop(s); - if (IsEmptyStack(s)) - break; - } - if (store.length > 0) { /* Push non-empty line onto indentation stack */ - store.indentation = indentcounter; - s = Push(s, store); - } - if (!(IsEmptyQueue(q))) { - if ((store.col != (*(FrontOfQueue(q))).Element.col) - || (!(*(FrontOfQueue(q))).Element.col)) - q = WriteQueue(q); /* If internal alignment changes or there is none - write out lines */ - } - q = AddToQueue(q, store); /* Add to writing queue */ - linecounter = 0; /* Get ready to count leading spaces */ - store.length = linecounter; - fscanf(ifptr, "%c", &c); /* Read next character */ - } - else break; - } - if (tripped) { - indentcounter = linecounter; - store.indentation = linecounter; - store.col = 0; - } - if ((tripped) && (linecounter)) { /* Skipover necessary for indentation */ - store = SelectSkipLine(s, store, linecounter); - store.indentation = linecounter; - store.col = 0; - } - if (!feof(ifptr)) - tripped = 0; /* No longer just taken new line */ - while ((!(isspace(c))) && (!(feof(ifptr)))) { /* Read word */ - if ((linecounter > 1) && (!IsEmptyQueue(q)) - && ((*(RearOfQueue(q))).Element.length >= linecounter) - && (linecounter > store.indentation) - && (linecounter > (*(RearOfQueue(q))).Element.indentation) - && (store.chars[linecounter - 1] == ' ') - && ((((*(RearOfQueue(q))).Element.chars[linecounter - 1] == ' ') - && ((c == (*(RearOfQueue(q))).Element.chars[linecounter]) - || ((c == '=') - && ((*(RearOfQueue(q))).Element.chars[linecounter] == ':') - && ((*(RearOfQueue(q))).Element.chars[linecounter + 1] == ':')))) - || (((*(RearOfQueue(q))).Element.chars[linecounter - 1] == ':') - && ((*(RearOfQueue(q))).Element.chars[linecounter] == ':') - && (c == '='))) - && ((store.chars[linecounter - 2] == ' ') - || ((*(RearOfQueue(q))).Element.chars[linecounter - 2] == ' ')) - && (((*(RearOfQueue(q))).Element.col == 0) - || ((*(RearOfQueue(q))).Element.col == linecounter))) { - store.col = linecounter; /* Identify any internal alignment */ - (*(RearOfQueue(q))).Element.col = linecounter; - } - if ((c == '"') && (!incharquote) /* String outside comments */ - && (!inregcomment) && (!inlinecomment)) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - instring = !instring; - } - else if ((c == '"') && (!incharquoteincomment) /* String inside comment */ - && (!inbackquoteincomment) - && ((inregcomment) || (inlinecomment))) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - instringincomment = !instringincomment; - } - else if ((c == '`') && ((inlinecomment) || (inregcomment))) { - if ((linecounter) && (store.chars[linecounter - 1] == '`')) - inbackquoteincomment = 2; /* Opening LaTeX style quote in comment */ - else - inbackquoteincomment = !inbackquoteincomment; /* Backquote in comment */ - } - else if ((linecounter) && (!inlinecomment) && (!instring)) { - if ((store.chars[linecounter - 1] == '{') && (c == '-')) - inregcomment++; /* Haskell "{-" regional comment begin */ - else if ((store.chars[linecounter - 1] == '-') && (c == '}')) { - inregcomment--; /* Haskell "-}" regional comment end */ - instringincomment = 0; - incharquoteincomment = 0; - inbackquoteincomment = 0; - } - } - if (c == '|') { - if ((!IsEmptyQueue(q)) - && ((((*(RearOfQueue(q))).Element.chars[linecounter] == '=') - && (linecounter == store.indentation)) - || ((*(RearOfQueue(q))).Element.typeface[linecounter] == BE))) - store.typeface[linecounter] = BE; - else - store.typeface[linecounter] = MA; - } - else if ((c == '\'') && (linecounter) && (store.chars[linecounter - 1] == '\\')) - store.typeface[linecounter] = EQ; /* Escape character quote */ - else if ((c == '\'') && (!instring) && (!inregcomment) && (!inlinecomment)) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\') - && ((IsHaskellPunc(store.chars[linecounter - 1])) || (incharquote))) - || (!linecounter)) { - incharquote = !incharquote; - store.typeface[linecounter] = FQ; /* Character quote */ - } - else - store.typeface[linecounter] = MA; /* Prime */ - } - else if ((c == '\'') && (!instringincomment) - && ((inregcomment) || (inlinecomment))) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\') - && ((IsHaskellPunc(store.chars[linecounter - 1])) - || (incharquoteincomment))) - || (!linecounter)) { - incharquoteincomment = !incharquoteincomment; - store.typeface[linecounter] = FQ; /* Character quote in comment */ - } - else if (inbackquoteincomment) { - inbackquoteincomment--; - store.typeface[linecounter] = BF; /* `x' character quote in comment */ - } - else - store.typeface[linecounter] = MA; /* Prime */ - } - else if (c == '"') { - if ((!incharquote) && (!incharquoteincomment) && (!inbackquoteincomment) - && ((instring) || (instringincomment))) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - store.typeface[linecounter] = DQ; /* Open doublequote */ - else if (store.chars[linecounter - 1] == '\\') - store.typeface[linecounter] = EE; /* Escape doublequote */ - } - else if ((!incharquote) && (!incharquoteincomment) && (!inbackquoteincomment)) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - store.typeface[linecounter] = QD; /* Close doublequote */ - else if (store.chars[linecounter - 1] == '\\') - store.typeface[linecounter] = EE; /* Escape doublequote */ - } - else - store.typeface[linecounter] = EE; /* Character quote of doublequote */ - } - else if (c == '`') { - if ((inlinecomment) || (inregcomment)) - store.typeface[linecounter] = CO; - else - store.typeface[linecounter] = MA; - } - else if ((linecounter) && (subscripts) && (c == '_') - && (store.typeface[linecounter - 1] == ID)) - store.typeface[linecounter] = SU; /* Subscript in identifier */ - else if (c == '*') - store.typeface[linecounter] = TI; /* Times - may be changed by double char */ - else if (IsMathsChar(c)) - store.typeface[linecounter] = MA; /* Maths characters */ - else if (IsNumber(c, store, linecounter, - ((!inregcomment) && (!instring) && (!inlinecomment)))) - store.typeface[linecounter] = NU; /* Numbers */ - else if ((instring) || (incharquote)) - store.typeface[linecounter] = ST; /* Characters in strings */ - else if ((inlinecomment) || (inregcomment)) - store.typeface[linecounter] = CO; /* Characters in comments */ - else { - if (insub) - store.typeface[linecounter] = IS; /* Subscript identifiers */ - else - store.typeface[linecounter] = ID; /* Others */ - } - if (linecounter) - if ((store.typeface[linecounter - 1] == IS) - && (store.typeface[linecounter] != IS)) - insub = 0; /* End of subscript identifier */ - store.chars[linecounter++] = c; /* Place character in store */ - if (linecounter > store.indentation + 1) - store = CheckForDoubleChar(store, linecounter); - if ((store.typeface[linecounter - 1] == LC) && (!inregcomment) - && (!instring) && (!incharquote)) { - instringincomment = 0; - incharquoteincomment = 0; - inbackquoteincomment = 0; - inlinecomment = 1; - } - else if ((store.typeface[linecounter - 1] == SU) - && (linecounter != store.indentation)) - insub = 1; - fscanf(ifptr, "%c", &c); /* Read next character */ - if (feof(ifptr)) - c = ' '; - if ((!inregcomment) && (!inlinecomment) && (!instring)) - store = CheckForKeyword(c, store, linecounter); /* Keywords not in comments or - strings to be in keyword typeface */ - } - insub = 0; - store.chars[linecounter] = '\0'; /* String terminating null character */ - store.length = linecounter; - } - if ((!tripped) && (!store.col)) /* If last line not in internal alignment */ - q = WriteQueue(q); /* write previous lines which might */ - if (!tripped) /* Put final line in queue if non-empty */ - q = AddToQueue(q, store); - if (feof(ifptr)) /* Write remaining lines */ - q = WriteRestOfQueue(q); - - printf("\\end{tabbing}\n"); /* End of Haskell program */ - - exit(0); - } -} diff --git a/ghc/Makefile b/ghc/Makefile index effd0a9e7a..3876e1b670 100644 --- a/ghc/Makefile +++ b/ghc/Makefile @@ -1,79 +1,71 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.2 1996/11/21 16:46:26 simonm Exp $ +# $Id: Makefile,v 1.3 1997/03/14 07:53:55 simonpj Exp $ +# -TOP=.. -include $(TOP)/ghc/mk/ghc.mk +TOP=. +include $(TOP)/mk/boilerplate.mk line = @echo "------------------------------------------------------------------------------" -define BuildLibs -$(line) -@echo "Building Libraries" -$(line) -@$(MAKE) -C lib depend all -endef - -define BuildCompiler -$(line) -@echo "Building Compiler" -$(line) -@$(MAKE) -C compiler depend all -endef - -# dependencies: +# +# subdir dependencies: # everything needs utils -# includes needs driver (for mkNativeGen.c) +# includes/ needs driver (to easily c.pile mkNativeGen.c) # make depend except in {utils,driver} needs includes # RTS and compiler need includes +# boot :: $(line) - @echo "Building Utils" + @echo "Booting Utils" $(line) - @$(MAKE) -C utils depend all + @$(MAKE) -C utils boot depend $(line) - @echo "Building Driver" + @echo "Booting Driver" $(line) - @$(MAKE) -C driver all + @$(MAKE) -C driver boot depend $(line) - @echo "Building Includes" + @echo "Booting Includes" $(line) - @$(MAKE) -C includes all + @$(MAKE) -C includes boot depend $(line) - @echo "Building Runtime System" + @echo "Booting Runtime System" $(line) - @$(MAKE) -C runtime depend all + @$(MAKE) -C runtime boot depend $(line) - @echo "Building Docs" + @echo "Booting Docs" $(line) - @$(MAKE) -C docs depend all + @$(MAKE) -C docs boot -ifeq ($(HaskellCompilerType), HC_USE_HC_FILES) - $(BuildLibs) - $(BuildCompiler) -else - $(BuildCompiler) - $(BuildLibs) -endif - -# "CONTRIB" is also a SUBDIR, but there is nothing to build there. -SUBDIRS = utils driver includes runtime docs compiler lib + $(line) + @echo "Booting Compiler" + $(line) + @$(MAKE) -C compiler boot -# Make the required directories for install. + $(line) + @echo "Booting Prelude libraries" + $(line) + @$(MAKE) -C compiler boot -install_dirs :: - $(MKDIRHIER) $(INSTBINDIR_GHC) - $(MKDIRHIER) $(INSTSCRIPTDIR_GHC) - $(MKDIRHIER) $(INSTLIBDIR_GHC) - $(MKDIRHIER) $(INSTLIBDIR_GHC)/includes - $(MKDIRHIER) $(INSTDATADIR_GHC) - $(MKDIRHIER) $(INSTDATADIR_GHC)/includes - $(MKDIRHIER) $(INSTDATADIR_GHC)/imports -install :: install_dirs +# "CONTRIB" is also a SUBDIR, but there is nothing to build there. +# +# leave out docs for the moment -- SOF +# +# Order is important! driver/ has to come before includes/ which +# again has to come before the rest. +# +# If we're booting from .hc files, swap the order +# we descend into compiler/ and lib/ +# +ifeq "$(GhcWithHscBuiltViaC)" "NO" +SUBDIRS = utils driver includes runtime compiler lib +else +SUBDIRS = utils driver includes runtime lib compiler +endif -include $(TOP)/mk/subdir.mk +include $(TOP)/mk/target.mk diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index c630c8dcfa..2a2b376b0d 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -36,6 +36,7 @@ you will screw up the layout where they are used in case expressions! # define _GT GT # define _Addr GHCbase.Addr # define Text Show +# define IMP_FASTSTRING() # define IMP_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase # define CHK_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase # define minInt (minBound::Int) @@ -45,8 +46,9 @@ you will screw up the layout where they are used in case expressions! # define EXP_MODULE(a) a.. # define IMPORT_DELOOPER(mod) import mod # define IMPORT_1_3(mod) {--} -# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) -# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) +# define IMP_FASTSTRING() import FastString +# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) ; import FastString +# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) ; import FastString #endif #if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200 @@ -107,21 +109,21 @@ you will screw up the layout where they are used in case expressions! #if __GLASGOW_HASKELL__ >= 23 # define USE_FAST_STRINGS 1 # if __GLASGOW_HASKELL__ < 200 -# define FAST_STRING _PackedString -# define SLIT(x) (_packCString (A# x#)) +# define FAST_STRING FastString {-_PackedString -} +# define SLIT(x) (mkFastCharString (A# (x#))) {- (_packCString (A# x#)) -} # define _CMP_STRING_ cmpPString /* cmpPString defined in utils/Util.lhs */ -# define _NULL_ _nullPS -# define _NIL_ _nilPS -# define _CONS_ _consPS -# define _HEAD_ _headPS -# define _TAIL_ _tailPS -# define _LENGTH_ _lengthPS -# define _PK_ _packString -# define _UNPK_ _unpackPS -# define _SUBSTR_ _substrPS -# define _APPEND_ `_appendPS` -# define _CONCAT_ _concatPS +# define _NULL_ nullFastString {-_nullPS-} +# define _NIL_ (mkFastString "") {-_nilPS -} +# define _CONS_ consFS {-_consPS-} +# define _HEAD_ headFS {-_headPS-} +# define _TAIL_ tailFS {-_tailPS-} +# define _LENGTH_ lengthFS {-_lengthPS-} +# define _PK_ mkFastString {-_packString-} +# define _UNPK_ unpackFS {-_unpackPS-} + /* # define _SUBSTR_ _substrPS */ +# define _APPEND_ `appendFS` {-`_appendPS`-} +# define _CONCAT_ concatFS {-_concatPS-} # else # define FAST_STRING GHCbase.PackedString # define SLIT(x) (packCString (GHCbase.A# x#)) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index dcf06812d8..b0b54d0a9b 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,260 +1,345 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.7 1997/01/17 00:32:23 simonpj Exp $ +# $Id: Makefile,v 1.8 1997/03/14 07:55:43 simonpj Exp $ -TOP = ../.. -FlexSuffixRules = YES -YaccSuffixRules = YES -SuffixRule_WantStdOnes = NO -include $(TOP)/ghc/mk/ghc.mk - -# Problem: don't know whether GhcWithHscBuiltViaC until now, so we have -# to re-include rules.mk to get the correct suffix rules. - -FlexSuffixRules = -YaccSuffixRules = -ifeq ($(GhcWithHscBuiltViaC),YES) - HC = $(GHC) - SuffixRule_hc_o = YES -else - HaskellSuffixRules = YES -endif -include $(TOP)/mk/rules.mk +TOP = .. +include $(TOP)/mk/boilerplate.mk #----------------------------------------------------------------------------- -# make libhsp.a - -YFLAGS = -d -v -CFLAGS = -Iparser -I. -IcodeGen -ARCHIVE = libhsp.a -DESTDIR = $(INSTLIBDIR_GHC) -UGN = $(wildcard parser/*.ugn) -UGNC = $(patsubst %.ugn, %.c, $(UGN)) -UGNH = $(patsubst %.ugn, %.h, $(UGN)) -UGNHS = $(patsubst parser/%.ugn, parser/U_%.hs, $(UGN)) -LIBOBJS = \ - $(patsubst %.c, %.o, $(UGNC)) parser/hslexer.o parser/hsparser.tab.o \ - parser/id.o parser/infix.o parser/syntax.o parser/type2context.o \ - parser/util.o - -parser/%.h parser/%.c parser/U_%.hs : parser/%.ugn - @$(RM) $@ parser/$*.hs parser/U_$*.hs parser/$*.h - $(UGEN) $< || $(RM) parser/$*.h parser/$*.hs - @$(MV) -f parser/$*.hs parser/U_$*.hs - @chmod 444 parser/$*.h parser/U_$*.hs - -parser/%.o : parser/%.c $(UGNH) - @$(RM) $@ - $(CC) $(CFLAGS) -c $< -o $@ - -clean :: - $(RM) parser/hslexer.c parser/hsparser.tab.h parser/hsparser.tab.c - -parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h - -include $(TOP)/mk/lib.mk +# Building hsc different ways (default is just `normal' sequential) +WAYS=$(GhcCompilerWays) #----------------------------------------------------------------------------- +# Set SUBDIRS ifeq ($(IncludeTestDirsInBuild),YES) SUBDIRS = tests endif -ifeq ($(Ghc2_0),YES) - %.hi : %_1_3.lhi - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ -else - %.hi : %.lhi - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ -endif +# ----------------------------------------------------------------------------- +# Set HS_PROG, LIBRARY +# Setting HS_PROG and LIBRARY causes all targets in target.mk +# (included below) to kick in. + +LIBRARY=libhsp.a +HS_PROG=hsc + + +# ----------------------------------------------------------------------------- +# Set SRCS, LOOPS, HCS, OBJS +# +# First figure out DIRS, the source sub-directories +# Then derive SRCS by looking in them +# DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ reader profiling parser -# ----------------------------------------------------------------------------- -# optional directories ifeq ($(GhcWithDeforester),YES) DIRS += deforest endif ifeq ($(GhcWithNativeCodeGen),YES) - DIRS += nativeGen -else ifeq ($(GhcWithHscBuiltViaC),YES) # If building via C, we *assume* that it is the distributed C files, # which do not have a native-code generator in them else DIRS += nativeGen endif +else +SRC_HC_OPTS += -DOMIT_NATIVE_CODEGEN endif -# ----------------------------------------------------------------------------- -# wildcard to get the lists of sources/objects -INCLUDEDIRS = $(foreach dir,$(DIRS),-i$(dir)) -SRCS = \ - $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ - $(UGNHS) rename/ParseIface.hs \ - main/LoopHack.hc +HS_SRCS = $(SRCS_UGNHS) \ + $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ + rename/ParseIface.hs rename/ParseType.hs rename/ParseUnfolding.hs \ + main/LoopHack.hc -# LoopHack.lhc is an SLPJ addition to fix a profiling problem. See comments -# inside it. +# NB: it's no good to include *.hs in the top-line wildcard, because the .hs files +# in parser/ may not have been created at that point. -LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi)) -HCS = $(patsubst %.hs, %.hc, $(patsubst %.lhs, %.hc, $(SRCS))) -OBJS = \ - $(patsubst %.hc, %.o, $(HCS)) rename/ParseIface.o \ - parser/hsclink.o parser/hschooks.o libhsp.a \ - main/LoopHack.o +LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi)) +HCS = $(patsubst %.lhs, %.hc, $(patsubst %.hs, %.hc, $(HS_SRCS))) -main/LoopHack.hc : main/LoopHack.lhc - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ +HS_OBJS = \ + $(patsubst %.hc, %.o, $(HCS)) \ + parser/hsclink.o parser/hschooks.o libhsp.a + + +DESTDIR = $(INSTALL_LIBRARY_DIR_GHC) + +SRCS_UGN = $(wildcard parser/*.ugn) +SRCS_UGNC = $(patsubst %.ugn, %.c, $(SRCS_UGN)) +SRCS_UGNH = $(patsubst %.ugn, %.h, $(SRCS_UGN)) +SRCS_UGNHS = $(patsubst parser/%.ugn, parser/U_%.hs, $(SRCS_UGN)) +SRCS_UGN_OBJS = $(patsubst %.c, %.o, $(SRCS_UGNC)) + +# +# Add the generated C files to the C_SRCS, so as to let `depend' +# generate correct dependencies for them. +# +C_SRCS += $(SRCS_UGNC) + +LIBOBJS = \ + $(SRCS_UGN_OBJS) parser/hslexer.o parser/hsparser.tab.o \ + parser/id.o parser/infix.o parser/syntax.o parser/type2context.o \ + parser/util.o -main/LoopHack.o : main/LoopHack.hc - $(HC) -v -c $(HC_OPTS) $< +# +# stuff you get for free in a source distribution +# +SRC_DIST_FILES += rename/ParseIface.hs \ + rename/ParseType.hs rename/ParseUnfolding.hs \ + parser/U_tree.c parser/tree.h parser/tree.c \ + parser/hsparser.tab.c parser/hsparser.tab.h \ + parser/hslexer.c # ----------------------------------------------------------------------------- -# options for the Haskell compiler +# Haskell compilations -MAKEFLAGS += --no-builtin-rules +# Compiler to use for building hsc +# +HC=$(WithGhcHc) -HC_OPTS += \ - -cpp $(HcMaxHeapFlag) $(HcMaxStackFlag) -fhaskell-1.3 \ +SRC_HC_OPTS += \ + -cpp -fhaskell-1.3 -syslib ghc \ -fglasgow-exts -DCOMPILING_GHC -Rghc-timing -I. -IcodeGen \ - -InativeGen -Iparser $(INCLUDEDIRS) + -InativeGen -Iparser $(foreach dir,$(DIRS),-i$(dir)) -# expect 12 shift/reduce conflicts and 0 reduce/reduce conflicts +# -syslib ghc just needed for utils/CharSeq.lhs use of PackedString.hPutPS -ifeq ($(GhcWithHscDebug),YES) - HC_OPTS += -DDEBUG - CFLAGS += -DDEBUG -endif -ifneq ($(Ghc2_0),YES) - HC_OPTS += -fomit-derived-read -fomit-reexported-instances -endif +SRC_CC_OPTS += -Iparser -I. -ifeq ($(GhcWithHscOptimised),YES) - HC_OPTS += -O -fshow-import-specs +ifneq ($(Ghc2_0),NO) + SRC_HC_OPTS += -fomit-derived-read -fomit-reexported-instances endif ifeq ($(GhcWithDeforester),NO) - HC_OPTS += -DOMIT_DEFORESTER + SRC_HC_OPTS += -DOMIT_DEFORESTER +endif + +SRC_HC_OPTS += $(GhcHcOpts) + +# Special flags for particular modules +# The standard suffix rule for compiling a Haskell file +# adds these flags to the command line + +absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances +basicTypes/IdInfo_HC_OPTS = -K2m +coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances +hsSyn/HsExpr_HC_OPTS = -K2m +hsSyn/HsSyn_HC_OPTS = -fno-omit-reexported-instances +main/Main_HC_OPTS = -fvia-C +main/CmdLineOpts_HC_OPTS = -fvia-C +nativeGen/PprMach_HC_OPTS = -K2m +parser/UgenAll_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/UgenUtil_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_constr_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_binding_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_pbinding_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_entidt_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_list_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_literal_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_maybe_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_either_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_qid_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_tree_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +prelude/PrimOp_HC_OPTS = -K3m +reader/Lex_HC_OPTS = -K2m +reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +rename/ParseIface_HC_OPTS = -Onot -H16m +rename/ParseType_HC_OPTS = -Onot -H16m +rename/ParseUnfolding_HC_OPTS = -Onot -H16m +ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9" +rename/RnMonad_HC_OPTS = -fvia-C -O2 -O2-for-C +else +rename/RnMonad_HC_OPTS = -fvia-C endif +rename/RnEnv_HC_OPTS = -fvia-C +rename/RnSource_HC_OPTS = -H12m +rename/RnIfaces_HC_OPTS = -H8m -fvia-C +rename/RnNames_HC_OPTS = -H12m +specialise/Specialise_HC_OPTS = -Onot -H12m +stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances +typecheck/TcMonad_HC_OPTS = -fvia-C +typecheck/TcGenDeriv_HC_OPTS = -H10m +typecheck/TcExpr_HC_OPTS = -H10m +utils/Argv_HC_OPTS = -fvia-C +utils/CharSeq_HC_OPTS = -fvia-C +utils/SST_HC_OPTS = -fvia-C +utils/PrimPacked_HC_OPTS = -fvia-C -monly-3-regs +utils/FastString_HC_OPTS = -fvia-C +utils/StringBuffer_HC_OPTS = -fvia-C + + +# ---------------------------------------------------------------------------- +# C compilations + +SRC_C_OPTS += -O -Iparser -I. -IcodeGen + # ---------------------------------------------------------------------------- +# Parsers -all :: hsc libhsp.a +# Main parser uses Yacc/Bison +SRC_YACC_OPTS += -d -v -hsc : $(OBJS) -# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ - $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ -# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ +# +# Want to keep the intermediate (included in src distribs). +# +.PRECIOUS: parser/%.tab.c parser/hslexer.c parser/hschooks.o : parser/hschooks.c @$(RM) $@ $(HC) -c -o $@ $(HCFLAGS) parser/hschooks.c + +# Interface-file parser uses Happy +SRC_HAPPY_OPTS += +RTS -K2m -H10m -RTS + rename/ParseIface.hs : rename/ParseIface.y @$(RM) rename/ParseIface.hs rename/ParseIface.hinfo - happy +RTS -K2m -H10m -RTS -g rename/ParseIface.y + $(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y @chmod 444 rename/ParseIface.hs -# ---------------------------------------------------------------------------- -# Special extra dependencies for yukky ugen stuff +rename/ParseType.hs : rename/ParseType.y + @$(RM) rename/ParseType.hs rename/ParseType.hinfo + $(HAPPY) $(HAPPY_OPTS) -g rename/ParseType.y + @chmod 444 rename/ParseType.hs -hspincl.h : $(UGNH) -parser/UgenAll.o : parser/hspincl.h -parser/UgenUtil.o : parser/hspincl.h -parser/U_constr.o : parser/hspincl.h -parser/U_binding.o : parser/hspincl.h -parser/U_pbinding.o : parser/hspincl.h -parser/U_entidt.o : parser/hspincl.h -parser/U_list.o : parser/hspincl.h -parser/U_literal.o : parser/hspincl.h -parser/U_maybe.o : parser/hspincl.h -parser/U_either.o : parser/hspincl.h -parser/U_qid.o : parser/hspincl.h -parser/U_tree.o : parser/hspincl.h -parser/U_ttype.o : parser/hspincl.h -reader/ReadPrefix.o : parser/hspincl.h +rename/ParseUnfolding.hs : rename/ParseUnfolding.y + @$(RM) rename/ParseUnfolding.hs rename/ParseUnfolding.hinfo + $(HAPPY) $(HAPPY_OPTS) -g rename/ParseUnfolding.y + @chmod 444 rename/ParseUnfolding.hs -# ---------------------------------------------------------------------------- -# Special flags for particular modules - -absCSyn/AbsCSyn_flags = -fno-omit-reexported-instances -hsSyn/HsExpr_flags = -K2m -hsSyn/HsSyn_flags = -fno-omit-reexported-instances -main/Main_flags = -fvia-C -basicTypes/IdInfo_flags = -K2m -main/CmdLineOpts_flags = -fvia-C -coreSyn/AnnCoreSyn_flags = -fno-omit-reexported-instances -nativeGen/PprMach_flags = -K2m -parser/UgenAll_flags = -fvia-C '-\#include"hspincl.h"' -parser/UgenUtil_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_constr_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_binding_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_pbinding_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_entidt_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_list_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_literal_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_maybe_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_either_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_qid_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_tree_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_ttype_flags = -fvia-C '-\#include"hspincl.h"' -prelude/PrimOp_flags = -K3m -reader/ReadPrefix_flags = -fvia-C '-\#include"hspincl.h"' -rename/ParseIface_flags = -Onot -H16m -rename/RnMonad_flags = -fvia-C -rename/RnSource_flags = -H12m -rename/RnIfaces_flags = -H8m -rename/RnNames_flags = -H12m -specialise/Specialise_flags = -Onot -H12m -stgSyn/StgSyn_flags = -fno-omit-reexported-instances -typecheck/TcMonad_flags = -fvia-C -typecheck/TcGenDeriv_flags = -H10m -typecheck/TcExpr_flags = -H10m -utils/Argv_flags = -fvia-C -utils/CharSeq_flags = -fvia-C -utils/SST_flags = -fvia-C +#---------------------------------------------------------------------- +# +# Building the stand-alone parser +# +all :: hsp + +hsp: parser/printtree.o parser/main.o libhsp.a + $(CC) -o $@ $(CC_OPTS) $^ + +#----------------------------------------------------------------------------- +# Interface files + +# LoopHack.lhc is an SLPJ addition to fix a profiling problem. See comments +# inside it. (compilation is handled by the suffix rules). + +# +# Building the loop breakers from .lhi files +# +ifeq ($(Ghc2_0),YES) + %.hi : %_1_3.lhi + $(RM) $@ + $(UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) + @chmod 444 $@ +else + %.hi : %.lhi + $(RM) $@ + $(UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) + @chmod 444 $@ +endif + +#----------------------------------------------------------------------------- +# Linking + +SRC_LD_OPTS += -no-link-chk + +# Build-specific +#SRC_LD_OPTS += "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" + + +#----------------------------------------------------------------------------- +# install + +# We don't want hsc treated as an ordinary executable, +# but put it together with the libraries. +# Also don't want any interface files intstalled + +INSTALL_LIBEXECS += hsc hsp #----------------------------------------------------------------------------- -# make depend, clean, tags and install +# depend + +# If we're using a 1.2 compiler to compile the compiler, need the old mkdepend stuff +# +# ToDo: define sep MKDEPENDHS_1.2 variable so that it can be readily overridden +# in a build.mk file. +# +ifeq ($(Ghc2_0),NO) +MKDEPENDHS = $(MKDEPENDHS_1_2) +endif -depend :: $(LOOPS) +# +# Before doing `make depend', need to build all derived Haskell source files +# +depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs rename/ParseUnfolding.hs rename/ParseType.hs -MKDEPENDHSFLAGS = -f .depend -I../includes -x HsVersions.h ifeq ($(GhcWithDeforester),NO) - MKDEPENDHSFLAGS += -DOMIT_DEFORESTER + SRC_MKDEPENDHS_OPTS += -DOMIT_DEFORESTER +endif + +ifeq ($(Ghc2_0),YES) +SRC_MKDEPENDHS_OPTS += $(SRC_HC_OPTS) endif ifeq ($(GhcWithHscBuiltViaC),YES) - MKDEPENDHSFLAGS += -o .hc + SRC_MKDEPENDHS_OPTS += -o .hc else - HS_DEP_SRCS = $(SRCS) # should add $(LOOPS) ? - include $(TOP)/mk/hsdepend.mk + SRCS_MKDEPENDHS = $(SRCS_HC) # should add $(LOOPS) ? endif -clean :: - $(RM) */*.o */*.hi $(UGNC) $(UGNH) $(UGNHS) - $(RM) rename/ParseIface.hs -veryclean :: - $(RM) */*.hc +#----------------------------------------------------------------------------- +# clean + +CLEAN_FILES += $(wildcard */*.$(way_)o */*.$(way_)hi) \ + $(SRCS_UGNC) $(SRCS_UGNH) \ + $(SRCS_UGNHS)\ + parser/hslexer.c parser/hsparser.tab.h parser/hsparser.tab.c + +# Extra tidy, remove the .hc files (if you've got them). +MAINTAINER_CLEAN_FILES += $(wildcard */*.hc) + + +#----------------------------------------------------------------------------- +# TAGS + +SRC_HSTAGS_OPTS += -fglasgow-exts -cpp + + +#----------------------------------------------------------------------------- +# Include target-rule boilerplate + +include $(TOP)/mk/target.mk + +# +# Special extra dependencies for yukky ugen stuff +# -tags :: - @$(RM) TAGS - @touch TAGS - $(HSTAGS) -I../includes $(HSTAGSFLAGS) $(SRCS) +parser/%.o : parser/%.c $(SRCS_UGNH) +parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h -install :: - $(INSTALL) $(INSTBINFLAGS) hsc $(INSTLIBDIR_GHC) +parser/hspincl.h : $(SRCS_UGNH) +parser/UgenAll.o : parser/hspincl.h +parser/UgenUtil.o : parser/hspincl.h +parser/U_constr.o : parser/hspincl.h +parser/U_binding.o : parser/hspincl.h +parser/U_pbinding.o : parser/hspincl.h +parser/U_entidt.o : parser/hspincl.h +parser/U_list.o : parser/hspincl.h +parser/U_literal.o : parser/hspincl.h +parser/U_maybe.o : parser/hspincl.h +parser/U_either.o : parser/hspincl.h +parser/U_qid.o : parser/hspincl.h +parser/U_tree.o : parser/hspincl.h +parser/U_ttype.o : parser/hspincl.h +parser/printtree.o : parser/hspincl.h +reader/ReadPrefix.o : parser/hspincl.h diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES new file mode 100644 index 0000000000..6ad337559d --- /dev/null +++ b/ghc/compiler/NOTES @@ -0,0 +1,129 @@ +* CHECK that the things seek_liftable found are done in Core + +* CHECK that there aren't too many indirections in STG + local = ... + global = local Int + +Interface files +~~~~~~~~~~~~~~~ +* Don't need to pin a kind on the type variable in a interface class decl, + because it'll be correctly re-inferred when we read it in. + +* The double semicolon at the end of an interface-file signature is so that + the lexer can run through the pragmas very fast when -O isn't being used. + +* In export lists, T!(A,B) says that constructors A and B are exported, + but not the type T. Similarly for classes. + +=========================================================================== + + Nofib failures + ~~~~~~~~~~~~~~ + +* spectral/hartel/wave4main, wang, spectral/simple, real/symalg + +Bus error + +* real/anna + +expected stdout not matched by reality +*** big.sum.out Thu Aug 22 14:37:05 1996 +--- /tmp/runtest21900.1 Mon Jan 20 17:57:49 1997 +*************** +*** 1 **** +! 12796 49 +--- 1 ---- +! 63325 97 + + +* /real/compress2 + +expected stderr not matched by reality +Warning: missing newline at end of file /tmp/runtest14691.2 +*** /tmp/no_stderr14691 Thu Jan 23 14:33:29 1997 +--- /tmp/runtest14691.2 Thu Jan 23 14:33:29 1997 +*************** +*** 0 **** +--- 1,2 ---- ++ ++ Fail: Prelude.Enum.Char.toEnum:out of range + + +* real/ebnf2ps + +IOSupplement.hs: 43: value not in scope: getEnv + + ...and... + +HappyParser.hs: 127: Couldn't match the type + [HappyParser.Token'] against PrelBase.Int + Expected: HappyParser.HappyReduction + Inferred: PrelBase.Int -> HappyParser.Token' -> HappyParser.HappyState HappyParser.Token' ([HappyParser.HappyAbsSyn] -> [AbstractSyntax.Production]) -> PrelBase.Int -> PrelBase.Int -> o{-a1yN-} -> o{-a1yO-} -> [HappyParser.Token'] -> a{-a1yP-} + In an equation for function HappyParser.action_1: + HappyParser.action_1 _ = HappyParser.happyFail + + +* GHC_ONLY/bugs/andy_cherry + +DataTypes.lhs: 3: Could not find valid interface file for `GenUtils' + +Need "make depend" + +* GHC_ONLY/bugs/lex + +Pattern match fail in lex; must be producing empty or multi-valued result + +Aggravated by dreadful error messages: ++ ++ Fail: In irrefutable pattern ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matchingtoo many nested calls to `error' + + +* GHC_ONLY/bugs/jtod_circint + +Main.hs: 12: No instance for: Signal.Signal (Signal.Stream Bit.Bit) + Main.hs: 12: at a use of an overloaded identifier: `Signal.one' + +instance-decl slurping is WRONG + +* GHC_ONLY/arith005 + +ceiling doesn't work properly + +--- 1,3 ---- ++ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4] ++ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4] + [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] +*************** +*** 2,5 **** + [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] +- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] +- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] + [0, 0, 1, 2, 3, 4, -1, -3, -4, -5, 1000012, 123, 100, 102, 0, -1, 17000, -1, 0, 3] +--- 4,5 ---- + + +* GHC_ONLY/bugs/lennart_array + +Wrong array semantics (but who cares?) + +* GHC_ONLY/bugs/life_space_leak + +-n *** sum I got: +0 0 +-n *** sum I expected: +02845 1350 diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 98464fa3eb..7c9444c601 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -363,12 +363,12 @@ pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), + uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")), uppPStr SLIT("__")] pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), + uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")), uppPStr SLIT("__")] pprCLabel sty (IdLabel (CLabelId id) flavor) diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 5c03e36d6d..4c0a636ff9 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -367,8 +367,9 @@ stmtMacroCosts macro modes = GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -} GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} + GRAN_YIELD -> nullCosts {- GrAnSim bookkeeping -- added SOF -} THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -} - _ -> trace "Costs.stmtMacroCosts" nullCosts + _ -> trace ("Costs.stmtMacroCosts: "++show macro) nullCosts -- --------------------------------------------------------------------------- diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index 0958307f37..ee58c6f5a1 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -305,7 +305,7 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs else if fxdhdr_offs _EQ_ ILIT(1) then Just (uppPStr SLIT("_FHS")) else - Just (uppBesides [uppStr "(_FHS*", uppInt IBOX(fxdhdr_offs), uppChar ')']) + Just (uppBesides [uppChar '(', uppPStr SLIT("_FHS*"), uppInt IBOX(fxdhdr_offs), uppChar ')']) pp_varhdr_offs = pp_hdrs (uppPStr SLIT("_VHS")) varhdr_offs diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index e73bf1576f..b2e60c492a 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -88,7 +88,7 @@ emitMacro :: CostRes -> Unpretty -- ToDo: Check a compile time flag to decide whether a macro should be emitted emitMacro (Cost (i,b,l,s,f)) - = uppBesides [ uppStr "GRAN_EXEC(", + = uppBesides [ uppPStr SLIT("GRAN_EXEC"), uppChar '(', uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, uppInt s, uppComma, uppInt f, pp_paren_semi ] \end{code} @@ -114,21 +114,21 @@ pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src pprAbsC sty (CJump target) c = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ]) - (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) + (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ]) pprAbsC sty (CFallThrough target) c = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ]) - (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) + (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ]) -- -------------------------------------------------------------------------- -- Spit out GRAN_EXEC macro immediately before the return HWL pprAbsC sty (CReturn am return_info) c = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ]) - (uppBesides [uppStr "JMP_(", target, pp_paren_semi ]) + (uppBesides [uppStr jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen] + DirectReturn -> uppBesides [uppPStr SLIT("DIRECT"),uppChar '(', pprAmode sty am, uppRparen] DynamicVectoredReturn am' -> mk_vector (pprAmode sty am') StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"] @@ -232,7 +232,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ -- hence we can toss the provided cast... pprAbsC sty (CSimultaneous abs_c) c - = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"] + = uppBesides [uppPStr SLIT("{{"), pprAbsC sty abs_c c, uppPStr SLIT("}}")] pprAbsC sty stmt@(CMacroStmt macro as) _ = uppBesides [uppStr (show macro), uppLparen, @@ -285,7 +285,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ PprForC -> pp_exts _ -> uppNil, uppBesides [ - uppStr "SET_STATIC_HDR(", + uppPStr SLIT("SET_STATIC_HDR"),uppChar '(', pprCLabel sty closure_lbl, uppComma, pprCLabel sty info_lbl, uppComma, if_profiling sty (pprAmode sty cost_centre), uppComma, @@ -295,7 +295,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ ], uppNest 2 (uppBesides (map (ppr_item sty) amodes)), uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)), - uppStr "};" ] + uppPStr SLIT("};") ] } where info_lbl = infoTableLabelFromCI cl_info @@ -328,7 +328,7 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven = uppAboves [ uppBesides [ pp_info_rep, - uppStr "_ITBL(", + uppPStr SLIT("_ITBL"),uppChar '(', pprCLabel sty info_lbl, uppComma, -- CONST_ITBL needs an extra label for @@ -404,16 +404,16 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"'] pprAbsC sty (CRetVector lbl maybes deflt) c - = uppAboves [ uppStr "{ // CRetVector (lbl????)", + = uppAboves [ uppPStr SLIT("{ // CRetVector (lbl????)"), uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)), uppStr "} /*default=*/ {", pprAbsC sty deflt c, - uppStr "}"] + uppChar '}'] where ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/") ppr_maybe_amode sty (Just a) = pprAmode sty a pprAbsC sty stmt@(CRetUnVector label amode) _ - = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma, + = uppBesides [uppPStr SLIT("UNVECTBL"),uppChar '(', pp_static, uppComma, pprCLabel sty label, uppComma, pprAmode sty amode, uppRparen] where pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static") @@ -442,15 +442,20 @@ ppLocalness label const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const") ppLocalnessMacro for_fun{-vs data-} clabel - = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix -> - case (if isReadOnly clabel then "RO_" else "") of { suffix -> - if for_fun - then uppStr (prefix ++ "F_") - else uppStr (prefix ++ "D_" ++ suffix) - } } + = uppBesides [ uppChar (if externallyVisibleCLabel clabel then 'E' else 'I'), + if for_fun then + uppPStr SLIT("F_") + else + uppBeside (uppPStr SLIT("D_")) + (if isReadOnly clabel then + uppPStr SLIT("RO_") + else + uppNil)] \end{code} \begin{code} +jmp_lit = "JMP_(" + grab_non_void_amodes amodes = filter non_void amodes @@ -662,7 +667,7 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo (uppBesides [ if null non_void_results then uppNil - else uppPStr SLIT("%r = "), + else uppStr "%r = ", uppLparen, uppPStr op_str, uppLparen, uppIntersperse uppComma ccall_args, uppStr "));" @@ -693,13 +698,14 @@ ppr_casm_arg sty amode a_num -- for array arguments, pass a pointer to the body of the array -- (PTRS_ARR_CTS skips over all the header nonsense) ArrayRep -> (pp_kind, - uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen]) + uppBesides [uppPStr SLIT("PTRS_ARR_CTS"),uppChar '(', pp_amode, uppRparen]) ByteArrayRep -> (pp_kind, - uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen]) + uppBesides [uppPStr SLIT("BYTE_ARR_CTS"),uppChar '(', pp_amode, uppRparen]) -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents. ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), - uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"]) + uppBesides [uppPStr SLIT("ForeignObj_CLOSURE_DATA"),uppChar '(', + pp_amode, uppChar ')']) other -> (pp_kind, pp_amode) declare_local_var @@ -750,7 +756,7 @@ ppr_casm_results sty [r] liveness + ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), - uppBesides [ uppStr "constructForeignObj(", + uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(', liveness, uppComma, result_reg, uppComma, local_var, @@ -841,10 +847,10 @@ Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} pprAssign sty FloatRep dest@(CVal reg_rel _) src - = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + = uppBesides [ uppPStr SLIT("ASSIGN_FLT"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] pprAssign sty DoubleRep dest@(CVal reg_rel _) src - = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + = uppBesides [ uppPStr SLIT("ASSIGN_DBL"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] \end{code} Lastly, the question is: will the C compiler think the types of the @@ -924,7 +930,7 @@ no-cast case: \begin{code} pprAmode sty amode | mixedTypeLocn amode - = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(", + = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppPStr SLIT(")("), ppr_amode sty amode ]) | otherwise -- No cast needed = ppr_amode sty amode @@ -950,13 +956,13 @@ ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq) ppr_amode sty (CLbl label kind) = pprCLabel sty label ppr_amode sty (CUnVecLbl direct vectored) - = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma, + = uppBesides [uppChar '(',uppPStr SLIT("StgRetAddr"),uppChar ')', uppPStr SLIT("UNVEC"),uppChar '(', pprCLabel sty direct, uppComma, pprCLabel sty vectored, uppRparen] ppr_amode sty (CCharLike char) - = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ] + = uppBesides [uppPStr SLIT("CHARLIKE_CLOSURE"),uppChar '(', pprAmode sty char, uppRparen ] ppr_amode sty (CIntLike int) - = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ] + = uppBesides [uppPStr SLIT("INTLIKE_CLOSURE"),uppChar '(', pprAmode sty int, uppRparen ] ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"'] -- ToDo: are these *used* for anything? @@ -968,10 +974,10 @@ ppr_amode sty (CLitLit str _) = uppPStr str ppr_amode sty (COffset off) = pprHeapOffset sty off ppr_amode sty (CCode abs_C) - = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] + = uppAboves [ uppPStr SLIT("{ -- CCode"), uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] ppr_amode sty (CLabelledCode label abs_C) - = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"], + = uppAboves [ uppBesides [pprCLabel sty label, uppPStr SLIT(" = { -- CLabelledCode")], uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] ppr_amode sty (CJoinPoint _ _) @@ -980,7 +986,7 @@ ppr_amode sty (CJoinPoint _ _) ppr_amode sty (CTableEntry base index kind) = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(", ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index, - uppStr ")]"] + uppPStr SLIT(")]")] ppr_amode sty (CMacroExpr pk macro as) = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen, @@ -1353,7 +1359,7 @@ ppr_decls_Amode (CUnVecLbl direct vectored) returnTE (Nothing, if (dlbl_seen || not (needsCDecl direct)) && (vlbl_seen || not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) + else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen])) -} ppr_decls_Amode (CUnVecLbl direct vectored) @@ -1369,7 +1375,7 @@ ppr_decls_Amode (CUnVecLbl direct vectored) returnTE (Nothing, if ({-dlbl_seen ||-} not (needsCDecl direct)) && ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) + else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen])) ppr_decls_Amode (CTableEntry base index _) = ppr_decls_Amode base `thenTE` \ p1 -> diff --git a/ghc/compiler/basicTypes/Id.hi-boot b/ghc/compiler/basicTypes/Id.hi-boot new file mode 100644 index 0000000000..69169c0efa --- /dev/null +++ b/ghc/compiler/basicTypes/Id.hi-boot @@ -0,0 +1,8 @@ +_interface_ Id 1 +_exports_ + +_declarations_ + +1 type Id = Id.GenId Type.Type ; +1 data GenId ty ; + diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 2a7e85bd88..8419e0deeb 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -797,12 +797,8 @@ mkMethodSelId op_name rec_c op ty = addStandardIdInfo $ Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo -mkDefaultMethodId op_name uniq rec_c op gen ty - = Id uniq dm_name ty details NoPragmaInfo noIdInfo - where - dm_name = mkCompoundName name_fn uniq op_name - details = DefaultMethodId rec_c op gen - name_fn op_str = SLIT("dm_") _APPEND_ op_str +mkDefaultMethodId dm_name rec_c op gen ty + = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c op gen) NoPragmaInfo noIdInfo mkDictFunId dfun_name full_ty clas ity = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo @@ -822,7 +818,7 @@ mkWorkerId u unwrkr ty info where name = mkCompoundName name_fn u (getName unwrkr) details = WorkerId unwrkr - name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk") + name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo @@ -866,9 +862,11 @@ mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info mkPrimitiveId n ty primop = addStandardIdInfo $ Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo + \end{code} \begin{code} + type MyTy a b = GenType (GenTyVar a) b type MyId a b = GenId (MyTy a b) diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index 86680a8caa..eb21149694 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -3,7 +3,8 @@ Breaks the IdInfo/<everything> loops. \begin{code} interface IdLoop where -import PreludePS ( _PackedString ) +--import PreludePS ( _PackedString ) +import FastString ( FastString ) import PreludeStdIO ( Maybe ) import BinderInfo ( BinderInfo ) @@ -16,7 +17,13 @@ import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, nullIdEnv, lookupIdEnv, IdEnv(..), Id(..), GenId ) -import CostCentre ( CostCentre ) +import CostCentre ( CostCentre, + noCostCentre, subsumedCosts, cafifyCC, + useCurrentCostCentre, dontCareCostCentre, + overheadCostCentre, preludeCafsCostCentre, + preludeDictsCostCentre, mkAllCafsCC, + mkAllDictsCC, mkUserCC + ) import IdInfo ( IdInfo ) import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv ) import Literal ( Literal ) @@ -93,8 +100,16 @@ data UnfoldingGuidance | UnfoldIfGoodArgs Int Int [Bool] Int data CostCentre -\end{code} - - - +noCostCentre :: CostCentre +subsumedCosts :: CostCentre +useCurrentCostCentre :: CostCentre +dontCareCostCentre :: CostCentre +overheadCostCentre :: CostCentre +preludeCafsCostCentre :: CostCentre +preludeDictsCostCentre :: Bool -> CostCentre +mkAllCafsCC :: FastString -> FastString -> CostCentre +mkAllDictsCC :: FastString -> FastString -> Bool -> CostCentre +mkUserCC :: FastString -> FastString -> FastString -> CostCentre +cafifyCC :: CostCentre -> CostCentre +\end{code} diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index b94f150229..b561cc3c55 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -19,7 +19,7 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(Ratio) -- friends: -import PrimRep ( PrimRep(..) ) -- non-abstract +import PrimRep ( PrimRep(..), ppPrimRep ) -- non-abstract import TysPrim ( getPrimRepInfo, addrPrimTy, intPrimTy, floatPrimTy, doublePrimTy, charPrimTy, wordPrimTy ) @@ -190,11 +190,11 @@ instance Outputable Literal where ppr sty (MachStr s) | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"'] - | otherwise = ppStr (show (_UNPK_ s)) + | otherwise = ppBesides [ppChar '"', ppPStr s, ppChar '"'] ppr sty lit@(NoRepStr s) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppBesides [ppStr "_string_", ppStr (show (_UNPK_ s))] + | otherwise = ppBesides [ppPStr SLIT("_string_"), ppChar '"', ppPStr s,ppChar '"'] ppr sty (MachInt i signed) | codeStyle sty && out_of_range @@ -210,25 +210,25 @@ instance Outputable Literal where ppr sty (MachFloat f) | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f] - | otherwise = ppBesides [ppStr "_float_", ppRational f] + | otherwise = ppBesides [ppPStr SLIT("_float_"), ppRational f] ppr sty (MachDouble d) = ppRational d ppr sty (MachAddr p) | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p] - | otherwise = ppBesides [ppStr "_addr_", ppInteger p] + | otherwise = ppBesides [ppPStr SLIT("_addr_"), ppInteger p] ppr sty lit@(NoRepInteger i _) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppCat [ppStr "_integer_", ppInteger i] + | otherwise = ppCat [ppPStr SLIT("_integer_"), ppInteger i] ppr sty lit@(NoRepRational r _) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppCat [ppStr "_rational_", ppInteger (numerator r), ppInteger (denominator r)] + | otherwise = ppCat [ppPStr SLIT("_rational_"), ppInteger (numerator r), ppInteger (denominator r)] ppr sty (MachLitLit s k) | codeStyle sty = ppPStr s - | otherwise = ppBesides [ppStr "_litlit_", ppStr (show (_UNPK_ s))] + | otherwise = ppBesides [ppPStr SLIT("_litlit_ "), ppPrimRep k, ppStr " \"", ppPStr s, ppChar '"'] showLiteral :: PprStyle -> Literal -> String showLiteral sty lit = ppShow 80 (ppr sty lit) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 593d61bb53..ee1dfa658b 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -13,7 +13,8 @@ module Name ( -- The OccName type OccName(..), - pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, isTvOcc, + pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, + isTvOcc, isTCOcc, isVarOcc, prefixOccName, quoteInText, parenInCode, -- The Name type @@ -38,7 +39,7 @@ module Name ( -- Sets of Names NameSet(..), emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, - minusNameSet, elemNameSet, nameSetToList, addListToNameSet, + minusNameSet, elemNameSet, nameSetToList, addListToNameSet, isEmptyNameSet, -- Misc DefnInfo(..), @@ -65,7 +66,7 @@ import Pretty import Lex ( isLexSym, isLexConId ) import SrcLoc ( noSrcLoc, SrcLoc ) import Unique ( pprUnique, showUnique, Unique ) -import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, +import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet ) import UniqFM ( UniqFM ) import Util ( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) @@ -102,6 +103,11 @@ occNameString (VarOcc s) = s occNameString (TvOcc s) = s occNameString (TCOcc s) = s +prefixOccName :: FAST_STRING -> OccName -> OccName +prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s) +prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s) +prefixOccName prefix (TCOcc s) = TCOcc (prefix _APPEND_ s) + -- occNameFlavour is used only to generate good error messages, so it doesn't matter -- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for -- data constructors and values, but that makes everything else a bit more complicated. @@ -111,10 +117,17 @@ occNameFlavour (VarOcc s) | isLexConId s = "data constructor" occNameFlavour (TvOcc s) = "type variable" occNameFlavour (TCOcc s) = "type constructor or class" -isTvOcc :: OccName -> Bool +isVarOcc, isTCOcc, isTvOcc :: OccName -> Bool +isVarOcc (VarOcc s) = True +isVarOcc other = False + isTvOcc (TvOcc s) = True isTvOcc other = False +isTCOcc (TCOcc s) = True +isTCOcc other = False + + instance Eq OccName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } @@ -287,7 +300,8 @@ setNameVisibility mod (Local uniq occ loc) setNameVisibility mod name = name all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible - opt_EnsureSplittableC -- Splitting requires visiblilty + opt_EnsureSplittableC -- Splitting requires visiblilty + \end{code} %************************************************************************ @@ -408,13 +422,15 @@ instance Outputable Name where ppr sty name@(Global u m n _ _) = ppBesides [pp_name, pp_debug sty name] where pp_name | codeStyle sty = identToC qual_name - | otherwise = ppPStr qual_name - qual_name = m _APPEND_ SLIT(".") _APPEND_ occNameString n + | otherwise = ppBesides[ ppPStr m, ppChar '.', ppPStr pk_n] + pk_n = occNameString n + qual_name = m _APPEND_ SLIT(".") _APPEND_ pk_n -pp_debug PprDebug (Global uniq m n _ prov) = ppBesides [ppStr "{-", pprUnique uniq, ppStr ",", +pp_debug PprDebug (Global uniq m n _ prov) = ppBesides [ppStr "{-", pprUnique uniq, ppChar ',', pp_prov prov, ppStr "-}"] where - pp_prov (LocalDef _ _) = ppChar 'l' + pp_prov (LocalDef Exported _) = ppChar 'x' + pp_prov (LocalDef NotExported _) = ppChar 'l' pp_prov (Imported _ _) = ppChar 'i' pp_prov Implicit = ppChar 'p' pp_debug other name = ppNil @@ -426,9 +442,9 @@ pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov pprProvenance :: PprStyle -> Provenance -> Pretty pprProvenance sty (Imported mod loc) - = ppSep [ppStr "Imported from", pprModule sty mod, ppStr "at", ppr sty loc] + = ppSep [ppPStr SLIT("Imported from"), pprModule sty mod, ppPStr SLIT("at"), ppr sty loc] pprProvenance sty (LocalDef _ loc) - = ppSep [ppStr "Defined at", ppr sty loc] + = ppSep [ppPStr SLIT("Defined at"), ppr sty loc] pprProvenance sty Implicit = panic "pprNameProvenance: Implicit" \end{code} @@ -451,7 +467,9 @@ unionManyNameSets :: [NameSet] -> NameSet minusNameSet :: NameSet -> NameSet -> NameSet elemNameSet :: Name -> NameSet -> Bool nameSetToList :: NameSet -> [Name] +isEmptyNameSet :: NameSet -> Bool +isEmptyNameSet = isEmptyUniqSet emptyNameSet = emptyUniqSet unitNameSet = unitUniqSet mkNameSet = mkUniqSet diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index f4a3b2b388..e7453786b3 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -81,13 +81,18 @@ isNoSrcLoc other = False \begin{code} instance Outputable SrcLoc where ppr PprForUser (SrcLoc src_file src_line) - = ppBesides [ ppPStr src_file, ppStr ": ", ppStr (show IBOX(src_line)) ] + = ppBesides [ ppPStr src_file, ppChar ':', ppStr (show IBOX(src_line)) ] ppr sty (SrcLoc src_file src_line) - = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP, - ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")] - + = ppBesides [ppStr "{-# LINE ", ppStr (show IBOX(src_line)), ppSP, + ppChar '\"', ppPStr src_file, ppStr " #-}"] ppr sty (UnhelpfulSrcLoc s) = ppPStr s ppr sty NoSrcLoc = ppStr "<NoSrcLoc>" \end{code} + +{- + = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP, + ppChar '"', ppPStr src_file, ppPStr SLIT(" #-}")] + --ppPStr SLIT("\" #-}")] +-} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 76e5ab3e80..c60a989edd 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -80,14 +80,14 @@ mkSplitUniqSupply (C# c#) -- here comes THE MAGIC: mk_supply# - = unsafeInterleavePrimIO {-unsafe_interleave-} ( + = unsafe_interleave ( mk_unique `thenPrimIO` \ uniq -> mk_supply# `thenPrimIO` \ s1 -> mk_supply# `thenPrimIO` \ s2 -> returnPrimIO (MkSplitUniqSupply uniq s1 s2) ) where -{- +-- -- inlined copy of unsafeInterleavePrimIO; -- this is the single-most-hammered bit of code -- in the compiler.... @@ -97,7 +97,7 @@ mkSplitUniqSupply (C# c#) (r, new_s) = m s in (r, s) --} +-- mk_unique = _ccall_ genSymZh `thenPrimIO` \ (WHASH u#) -> returnPrimIO (I# (w2i (mask# `or#` u#))) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index a482b689d7..5f14e9fed8 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -114,6 +114,7 @@ module Unique ( listTyConKey, ltDataConKey, mainKey, mainPrimIoKey, + minusClassOpKey, monadClassKey, monadPlusClassKey, monadZeroClassKey, @@ -127,6 +128,7 @@ module Unique ( numClassKey, ordClassKey, orderingTyConKey, + otherwiseIdKey, packCStringIdKey, parErrorIdKey, parIdKey, @@ -148,6 +150,7 @@ module Unique ( return2GMPsTyConKey, returnIntAndGMPDataConKey, returnIntAndGMPTyConKey, + returnMClassOpKey, runSTIdKey, seqIdKey, showClassKey, @@ -658,6 +661,7 @@ to conjure them up during type checking. \begin{code} fromIntClassOpKey = mkPreludeMiscIdUnique 53 fromIntegerClassOpKey = mkPreludeMiscIdUnique 54 +minusClassOpKey = mkPreludeMiscIdUnique 69 fromRationalClassOpKey = mkPreludeMiscIdUnique 55 enumFromClassOpKey = mkPreludeMiscIdUnique 56 enumFromThenClassOpKey = mkPreludeMiscIdUnique 57 @@ -673,4 +677,7 @@ fromEnumClassOpKey = mkPreludeMiscIdUnique 65 mainKey = mkPreludeMiscIdUnique 66 mainPrimIoKey = mkPreludeMiscIdUnique 67 +returnMClassOpKey = mkPreludeMiscIdUnique 68 +-- Used for minusClassOp 69 +otherwiseIdKey = mkPreludeMiscIdUnique 70 \end{code} diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index dff94d2185..872827fba6 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -65,11 +65,10 @@ import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr ) import PrimRep ( isFollowableRep, PrimRep(..) ) import TyCon ( isPrimTyCon, tyConDataCons ) +import Type ( showTypeCategory ) import Unpretty ( uppShow ) import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) -myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)" -showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)" getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -563,7 +562,7 @@ closureCodeBody binder_info closure_info cc all_args body wrapper_maybe = get_ultimate_wrapper Nothing id where get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain" - = case (myWrapperMaybe x) of + = case myWrapperMaybe x of Nothing -> deflt Just xx -> get_ultimate_wrapper (Just xx) xx diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 2b23b93290..18902fc84b 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -67,7 +67,7 @@ import Id ( idType, import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppAboves, ppCat, ppStr ) +import Pretty ( ppAboves, ppCat, ppPStr ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import StgSyn ( SYN_IE(StgLiveVars) ) import Type ( typePrimRep ) @@ -689,11 +689,11 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds _) Nothing -> pprPanic "lookupBindC:no info!\n" (ppAboves [ - ppCat [ppStr "for:", ppr PprShowAll name], - ppStr "(probably: data dependencies broken by an optimisation pass)", - ppStr "static binds for:", + ppCat [ppPStr SLIT("for:"), ppr PprShowAll name], + ppPStr SLIT("(probably: data dependencies broken by an optimisation pass)"), + ppPStr SLIT("static binds for:"), ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], - ppStr "local binds for:", + ppPStr SLIT("local binds for:"), ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] ]) \end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index a786145a4a..4f2e58556c 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -57,11 +57,8 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg = let doing_profiling = opt_SccProfilingOn compiling_prelude = opt_CompilingGhcInternals - maybe_split = if opt_EnsureSplittableC - then CSplitMarker - else AbsCNop - - cinfo = MkCompInfo mod_name + maybe_split = if opt_EnsureSplittableC then CSplitMarker else AbsCNop + cinfo = MkCompInfo mod_name in if not doing_profiling then mkAbstractCs [ diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 99afabcf14..cff93925e2 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -94,9 +94,9 @@ lintCoreBindings sty whoDunnit spec_done binds pprPanic "" (ppAboves [ ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), msg sty, - ppStr "*** Offending Program ***", + ppPStr SLIT("*** Offending Program ***"), ppAboves (map (pprCoreBinding sty) binds), - ppStr "*** End of Offense ***" + ppPStr SLIT("*** End of Offense ***") ]) where lint_binds [] = returnL () @@ -126,9 +126,9 @@ lintUnfolding locn expr Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n" (ppAboves [msg PprForUser, - ppStr "*** Bad unfolding ***", + ppPStr SLIT("*** Bad unfolding ***"), ppr PprDebug expr, - ppStr "*** End unfolding ***"]) + ppPStr SLIT("*** End unfolding ***")]) Nothing \end{code} @@ -276,8 +276,6 @@ lintCoreArg e ty (VarArg v) lintCoreArg e ty a@(TyArg arg_ty) = -- ToDo: Check that ty is well-kinded and has no unbound tyvars - checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) - `seqL` case (getForAllTyExpandingDicts_maybe ty) of Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing @@ -415,18 +413,18 @@ data LintLocInfo instance Outputable LintLocInfo where ppr sty (RhsOf v) - = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + = ppBesides [ppr sty (getSrcLoc v), ppPStr SLIT(": [RHS of "), pp_binders sty [v], ppChar ']'] ppr sty (LambdaBodyOf b) = ppBesides [ppr sty (getSrcLoc b), - ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"] + ppPStr SLIT(": [in body of lambda with binder "), pp_binder sty b, ppChar ']'] ppr sty (BodyOfLetRec bs) = ppBesides [ppr sty (getSrcLoc (head bs)), - ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + ppPStr SLIT(": [in body of letrec with binders "), pp_binders sty bs, ppChar ']'] ppr sty (ImportedUnfolding locn) - = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]") + = ppBeside (ppr sty locn) (ppPStr SLIT(": [in an imported unfolding]")) pp_binders :: PprStyle -> [Id] -> Pretty pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs) @@ -543,7 +541,7 @@ checkInScope id spec loc scope errs id_name = getName id in if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then - ((),addErr errs (\sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) + ((),addErr errs (\sty -> ppCat [ppr sty id, ppPStr SLIT("is out of scope")]) loc) else ((),errs) @@ -555,54 +553,54 @@ checkTys ty1 ty2 msg spec loc scope errs \begin{code} mkCaseAltMsg :: CoreCaseAlts -> ErrMsg mkCaseAltMsg alts sty - = ppAbove (ppStr "Type of case alternatives not the same:") + = ppAbove (ppPStr SLIT("Type of case alternatives not the same:")) (ppr sty alts) mkCaseDataConMsg :: CoreExpr -> ErrMsg mkCaseDataConMsg expr sty - = ppAbove (ppStr "A case scrutinee not of data constructor type:") + = ppAbove (ppPStr SLIT("A case scrutinee not of data constructor type:")) (pp_expr sty expr) mkCaseNotPrimMsg :: TyCon -> ErrMsg mkCaseNotPrimMsg tycon sty - = ppAbove (ppStr "A primitive case on a non-primitive type:") + = ppAbove (ppPStr SLIT("A primitive case on a non-primitive type:")) (ppr sty tycon) mkCasePrimMsg :: TyCon -> ErrMsg mkCasePrimMsg tycon sty - = ppAbove (ppStr "An algebraic case on a primitive type:") + = ppAbove (ppPStr SLIT("An algebraic case on a primitive type:")) (ppr sty tycon) mkCaseAbstractMsg :: TyCon -> ErrMsg mkCaseAbstractMsg tycon sty - = ppAbove (ppStr "An algebraic case on some weird type:") + = ppAbove (ppPStr SLIT("An algebraic case on some weird type:")) (ppr sty tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg mkDefltMsg deflt sty - = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:") + = ppAbove (ppPStr SLIT("Binder in case default doesn't match type of scrutinee:")) (ppr sty deflt) mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg mkAppMsg fun arg expr sty - = ppAboves [ppStr "Argument value doesn't match argument type:", - ppHang (ppStr "Fun type:") 4 (ppr sty fun), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppPStr SLIT("Argument value doesn't match argument type:"), + ppHang (ppPStr SLIT("Fun type:")) 4 (ppr sty fun), + ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg mkTyAppMsg msg ty arg expr sty - = ppAboves [ppCat [ppPStr msg, ppStr "type application:"], - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppCat [ppPStr msg, ppPStr SLIT("type application:")], + ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), + ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg mkUsageAppMsg ty u expr sty - = ppAboves [ppStr "Illegal usage application:", - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Usage exp:") 4 (ppr sty u), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppPStr SLIT("Illegal usage application:"), + ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), + ppHang (ppPStr SLIT("Usage exp:")) 4 (ppr sty u), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkAlgAltMsg1 :: Type -> ErrMsg mkAlgAltMsg1 ty sty @@ -643,22 +641,22 @@ mkPrimAltMsg alt sty mkRhsMsg :: Id -> Type -> ErrMsg mkRhsMsg binder ty sty = ppAboves - [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + [ppCat [ppPStr SLIT("The type of this binder doesn't match the type of its RHS:"), ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)], - ppCat [ppStr "Rhs type:", ppr sty ty]] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)], + ppCat [ppPStr SLIT("Rhs type:"), ppr sty ty]] mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg mkRhsPrimMsg binder rhs sty - = ppAboves [ppCat [ppStr "The type of this binder is primitive:", + = ppAboves [ppCat [ppPStr SLIT("The type of this binder is primitive:"), ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)] ] mkSpecTyAppMsg :: CoreArg -> ErrMsg mkSpecTyAppMsg arg sty = ppAbove - (ppStr "Unboxed types in a type application (after specialisation):") + (ppPStr SLIT("Unboxed types in a type application (after specialisation):")) (ppr sty arg) pp_expr :: PprStyle -> CoreExpr -> Pretty diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 4b25be3d90..e16b6d9061 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -381,14 +381,16 @@ collectBinders :: ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) collectBinders expr - = (usages, tyvars, vals, body) + = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) } where (usages, tyvars, body1) = collectUsageAndTyBinders expr - (vals, body) = collectValBinders body1 +-- (vals, body) = collectValBinders body1 collectUsageAndTyBinders expr - = usages expr [] + = case usages expr [] of + ([],tyvars,body) -> ([],tyvars,body) + v -> v where usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc) usages other uacc @@ -411,7 +413,9 @@ collectUsageAndTyBinders expr collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar -> ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) collectValBinders expr - = go [] expr + = case go [] expr of + ([],body) -> ([],body) + v -> v where go acc (Lam (ValBinder v) b) = go (v:acc) b go acc body = (reverse acc, body) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 215f25b30e..f2077ba738 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -96,10 +96,15 @@ data SimpleUnfolding noUnfolding = NoUnfolding mkUnfolding inline_me expr - = CoreUnfolding (SimpleUnfolding - (mkFormSummary expr) - (calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr) - (occurAnalyseGlobalExpr expr)) + = let + -- strictness mangling (depends on there being no CSE) + ufg = calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr + occ = occurAnalyseGlobalExpr expr + cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ) + + cont = case occ of { Var _ -> cuf; _ -> cuf } + in + case ufg of { UnfoldAlways -> cont; _ -> cont } mkMagicUnfolding :: Unique -> Unfolding mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag) @@ -128,10 +133,10 @@ data UnfoldingGuidance \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldAlways = ppStr "_ALWAYS_" --- ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface + ppr sty UnfoldAlways = ppPStr SLIT("_ALWAYS_") +-- ppr sty EssentialUnfolding = ppPStr SLIT("_ESSENTIAL_") -- shouldn't appear in an iface ppr sty (UnfoldIfGoodArgs t v cs size) - = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v, + = ppCat [ppPStr SLIT("_IF_ARGS_"), ppInt t, ppInt v, if null cs -- always print *something* then ppChar 'X' else ppBesides (map (ppStr . show) cs), @@ -154,10 +159,10 @@ data FormSummary | OtherForm -- Anything else instance Outputable FormSummary where - ppr sty VarForm = ppStr "Var" - ppr sty ValueForm = ppStr "Value" - ppr sty BottomForm = ppStr "Bot" - ppr sty OtherForm = ppStr "Other" + ppr sty VarForm = ppPStr SLIT("Var") + ppr sty ValueForm = ppPStr SLIT("Value") + ppr sty BottomForm = ppPStr SLIT("Bot") + ppr sty OtherForm = ppPStr SLIT("Other") mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary @@ -238,9 +243,7 @@ calcUnfoldingGuidance calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so calcUnfoldingGuidance False bOMB_OUT_SIZE expr - = let - (use_binders, ty_binders, val_binders, body) = collectBinders expr - in + = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) -> case (sizeExpr bOMB_OUT_SIZE val_binders body) of Nothing -> UnfoldNever @@ -250,7 +253,7 @@ calcUnfoldingGuidance False bOMB_OUT_SIZE expr (length ty_binders) (length val_binders) (map discount_for val_binders) - size + size where discount_for b | is_data && b `is_elem` cased_args = tyConFamilySize tycon @@ -261,7 +264,7 @@ calcUnfoldingGuidance False bOMB_OUT_SIZE expr Nothing -> (False, panic "discount") Just (tc,_,_) -> (True, tc) - is_elem = isIn "calcUnfoldingGuidance" + is_elem = isIn "calcUnfoldingGuidance" } \end{code} \begin{code} @@ -350,27 +353,27 @@ sizeExpr bOMB_OUT_SIZE args expr ------------ size_up_alts scrut_ty (AlgAlts alts deflt) - = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts `addSizeN` 1 - -- "1" for the case itself + = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts + `addSizeN` + alt_cost + where + size_alg_alt (con,args,rhs) = size_up rhs + -- Don't charge for args, so that wrappers look cheap - -- `addSizeN` (if is_data then tyConFamilySize tycon else 1) - -- - -- OLD COMMENT: looks unfair to me! So I've nuked this extra charge - -- SLPJ Jan 97 -- NB: we charge N for an alg. "case", where N is -- the number of constructors in the thing being eval'd. -- (You'll eventually get a "discount" of N if you -- think the "case" is likely to go away.) + -- It's important to charge for alternatives. If you don't then you + -- get size 1 for things like: + -- case x of { A -> 1#; B -> 2#; ... lots } - where - size_alg_alt (con,args,rhs) = size_up rhs - -- Don't charge for args, so that wrappers look cheap - - (is_data,tycon) + alt_cost :: Int + alt_cost = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $ case (maybeAppDataTyConExpandingDicts scrut_ty) of - Nothing -> (False, panic "size_up_alts") - Just (tc,_,_) -> (True, tc) + Nothing -> 1 + Just (tc,_,_) -> tyConFamilySize tc size_up_alts _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index d7dd124077..9ee12f3202 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -95,11 +95,20 @@ init_ppr_env sty tvbndr pbdr1 pbdr2 pocc (Just (pprParendGenType sty)) -- types (Just (ppr sty)) -- usages where + + ppr_con con = ppr sty con + +{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.] + [We can't treat them as ordinary applications because the Con doesn't have + dictionaries in it, whereas the constructor Id does.] + + OLD VERSION: -- ppr_con is used when printing Con expressions; we add a "!" -- to distinguish them from ordinary applications. But not when -- printing for interfaces, where they are treated as ordinary applications ppr_con con | ifaceStyle sty = ppr sty con | otherwise = ppr sty con `ppBeside` ppChar '!' +-} -- We add a "!" to distinguish Primitive applications from ordinary applications. -- But not when printing for interfaces, where they are treated @@ -113,9 +122,9 @@ pprCoreBinding sty (NonRec binder expr) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) pprCoreBinding sty (Rec binds) - = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"), + = ppAboves [ifPprDebug sty (ppPStr SLIT("{- plain Rec -}")), ppAboves (map ppr_bind binds), - ifPprDebug sty (ppStr "{- end plain Rec -}")] + ifPprDebug sty (ppPStr SLIT("{- end plain Rec -}"))] where ppr_bind (binder, expr) = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) @@ -163,7 +172,7 @@ pprIfaceUnfolding = ppr_expr env where env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) (pprTypedCoreBinder PprInterface) - (pprTypedCoreBinder PprInterface) + (ppr PprInterface) (ppr PprInterface) ppr_core_arg sty pocc arg @@ -252,11 +261,10 @@ ppr_parend_expr pe expr \begin{code} ppr_expr pe (Var name) = pOcc pe name ppr_expr pe (Lit lit) = pLit pe lit -ppr_expr pe (Con con []) = pCon pe con ppr_expr pe (Con con args) = ppHang (pCon pe con) - 4 (ppSep (map (ppr_arg pe) args)) + 4 (ppCurlies $ ppSep (map (ppr_arg pe) args)) ppr_expr pe (Prim prim args) = ppHang (pPrim pe prim) @@ -268,12 +276,12 @@ ppr_expr pe expr@(Lam _ _) in ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars, pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, - pp_vars SLIT("\\") (pMinBndr pe) vars]) + pp_vars SLIT("\\") (pMajBndr pe) vars]) 4 (ppr_expr pe body) where pp_vars lam pp [] = ppNil pp_vars lam pp vs - = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"] + = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppPStr SLIT("->")] ppr_expr pe expr@(App fun arg) = let @@ -288,18 +296,22 @@ ppr_expr pe (Case expr alts) -- johan thinks that single case patterns should be on same line as case, -- and no indent; all sane persons agree with him. = let - ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->") - ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->") - ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->") + + ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) ppr_arrow ppr_alt (AlgAlts ((con, params, _):[]) NoDefault) = ppCat [pCon pe con, ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"] + ppr_arrow] ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr + + + ppr_arrow = ppPStr SLIT(" ->") in ppSep [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts], @@ -307,7 +319,7 @@ ppr_expr pe (Case expr alts) | otherwise -- default "case" printing = ppSep - [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"], + [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppPStr SLIT("of {")], ppNest 2 (ppr_alts pe alts), ppStr "}"] where @@ -320,27 +332,27 @@ ppr_expr pe (Case expr alts) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = ppAboves [ - ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals], + ppCat [ppPStr SLIT("let {"), pMajBndr pe val_bdr, ppEquals], ppNest 2 (ppr_expr pe rhs), - ppStr "} in", + ppPStr SLIT("} in"), ppr_expr pe body ] ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = ppAbove - (ppHang (ppStr "let {") + (ppHang (ppPStr SLIT("let {")) 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) 4 (ppr_expr pe rhs), - ppStr "} in"])) + ppPStr SLIT("} in")])) (ppr_expr pe expr) -- general case (recursive case, too) ppr_expr pe (Let bind expr) - = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind), - ppHang (ppStr "} in ") 2 (ppr_expr pe expr)] + = ppSep [ppHang (ppPStr keyword) 2 (ppr_bind pe bind), + ppHang (ppPStr SLIT("} in ")) 2 (ppr_expr pe expr)] where keyword = case bind of - Rec _ -> "letrec {" - NonRec _ _ -> "let {" + Rec _ -> SLIT("letrec {") + NonRec _ _ -> SLIT("let {") ppr_expr pe (SCC cc expr) = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], @@ -349,8 +361,8 @@ ppr_expr pe (SCC cc expr) ppr_expr pe (Coerce c ty expr) = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr] where - pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = ppBeside (ppPStr SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) + pp_coerce (CoerceOut v) = ppBeside (ppPStr SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) only_one_alt (AlgAlts [] (BindDefault _ _)) = True only_one_alt (AlgAlts (_:[]) NoDefault) = True @@ -363,14 +375,16 @@ only_one_alt _ = False ppr_alts pe (AlgAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] where + ppr_arrow = ppPStr SLIT("->") + ppr_alt (con, params, expr) = ppHang (if isTupleCon con then ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), - ppStr "->"] + ppr_arrow] else ppCat [pCon pe con, ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"] + ppr_arrow] ) 4 (ppr_expr pe expr `ppBeside` ppSemi) @@ -378,7 +392,7 @@ ppr_alts pe (PrimAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] where ppr_alt (lit, expr) - = ppHang (ppCat [pLit pe lit, ppStr "->"]) + = ppHang (ppCat [pLit pe lit, ppPStr SLIT("->")]) 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} @@ -386,14 +400,14 @@ ppr_alts pe (PrimAlts alts deflt) ppr_default pe NoDefault = ppNil ppr_default pe (BindDefault val_bdr expr) - = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"]) + = ppHang (ppCat [pMinBndr pe val_bdr, ppPStr SLIT("->")]) 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} \begin{code} ppr_arg pe (LitArg lit) = pLit pe lit ppr_arg pe (VarArg v) = pOcc pe v -ppr_arg pe (TyArg ty) = ppStr "_@_ " `ppBeside` pTy pe ty +ppr_arg pe (TyArg ty) = ppPStr SLIT("_@_ ") `ppBeside` pTy pe ty ppr_arg pe (UsageArg use) = pUse pe use \end{code} @@ -417,7 +431,7 @@ pprBabyCoreBinder sty binder pp_strictness = case (getIdStrictness binder) of NoStrictnessInfo -> ppNil - BottomGuaranteed -> ppStr "{- _!_ -}" + BottomGuaranteed -> ppPStr SLIT("{- _!_ -}") StrictnessInfo xx _ -> panic "PprCore:pp_strictness:StrictnessInfo:ToDo" -- ppStr ("{- " ++ (showList xx "") ++ " -}") @@ -425,7 +439,7 @@ pprBabyCoreBinder sty binder pprTypedCoreBinder sty binder = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)] -ppDcolon = ppStr " :: " +ppDcolon = ppPStr SLIT(" :: ") -- The space before the :: is important; it helps the lexer -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 697c32dd2f..40e3bcc1fc 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -6,23 +6,28 @@ \begin{code} #include "HsVersions.h" -module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where +module Desugar ( deSugar, DsMatchContext, pprDsWarnings, + DsWarnFlavour -- removed when compiling with 1.4 + ) where IMP_Ubiq(){-uitous-} import HsSyn ( HsBinds, HsExpr ) import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) import CoreSyn - +import Name ( isExported ) import DsMonad import DsBinds ( dsBinds, dsInstBinds ) import DsUtils import Bag ( unionBags ) -import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) +import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, opt_SccGroup + ) +import CostCentre ( IsCafCC(..), mkAutoCC ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) -import Id ( nullIdEnv, mkIdEnv ) +import Id ( nullIdEnv, mkIdEnv, idType, SYN_IE(DictVar), GenId ) import PprStyle ( PprStyle(..) ) import UniqSupply ( splitUniqSupply ) \end{code} @@ -42,7 +47,7 @@ deSugar :: UniqSupply -- name supply -- ToDo: handling of const_inst thingies is certainly WRONG *************************** -> ([CoreBinding], -- output - Bag DsMatchContext) -- Shadowing complaints + DsWarnings) -- Shadowing complaints deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs) = let @@ -52,9 +57,11 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst (us3, us3a) = splitUniqSupply us2a (us4, us5) = splitUniqSupply us3a - auto_meth = opt_AutoSccsOnAllToplevs - auto_top = opt_AutoSccsOnAllToplevs - || opt_AutoSccsOnExportedToplevs + + module_and_group = (mod_name, grp_name) + grp_name = case opt_SccGroup of + Just xx -> _PK_ xx + Nothing -> mod_name -- default: module name ((core_const_prs, consts_pairs), shadows1) = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) @@ -62,19 +69,19 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst consts_env = mkIdEnv consts_pairs (core_clas_binds, shadows2) - = initDs us1 consts_env mod_name (dsBinds False clas_binds) + = initDs us1 consts_env mod_name (dsBinds clas_binds) core_clas_prs = pairsFromCoreBinds core_clas_binds (core_inst_binds, shadows3) - = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds) + = initDs us2 consts_env mod_name (dsBinds inst_binds) core_inst_prs = pairsFromCoreBinds core_inst_binds (core_val_binds, shadows4) - = initDs us3 consts_env mod_name (dsBinds auto_top val_binds) - core_val_pairs = pairsFromCoreBinds core_val_binds + = initDs us3 consts_env mod_name (dsBinds val_binds) + core_val_pairs = map (addAutoScc module_and_group) (pairsFromCoreBinds core_val_binds) (core_recsel_binds, shadows5) - = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds) + = initDs us4 consts_env mod_name (dsBinds recsel_binds) core_recsel_prs = pairsFromCoreBinds core_recsel_binds final_binds @@ -98,3 +105,29 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst in (really_final_binds, shadows) \end{code} + + +%************************************************************************ +%* * +\subsection[addAutoScc]{Adding automatic sccs} +%* * +%************************************************************************ + +\begin{code} +addAutoScc :: (FAST_STRING, FAST_STRING) -- Module and group + -> (Id, CoreExpr) + -> (Id,CoreExpr) + +addAutoScc (mod, grp) pair@(bndr, core_expr) + | worthSCC core_expr && + (opt_AutoSccsOnAllToplevs || + (isExported bndr && opt_AutoSccsOnExportedToplevs)) + = (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr) + + | otherwise + = pair + +worthSCC (SCC _ _) = False +worthSCC (Con _ _) = False +worthSCC core_expr = True +\end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 657e2652f1..af09307aba 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -29,7 +29,8 @@ import DsGRHSs ( dsGuarded ) import DsUtils import Match ( matchWrapper ) -import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_CompilingGhcInternals ) +import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals ) import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre ) import Id ( idType, SYN_IE(DictVar), GenId ) import ListSetOps ( minusList, intersectLists ) @@ -59,7 +60,7 @@ that some of the binders are of unboxed type. This is sorted out when the caller wraps the bindings round an expression. \begin{code} -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] \end{code} All ``real'' bindings are expressed in terms of the @@ -95,12 +96,12 @@ But there are lots of special cases. %============================================== \begin{code} -dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith" -dsBinds auto_scc EmptyBinds = returnDs [] -dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind +dsBinds (BindWith _ _) = panic "dsBinds:BindWith" +dsBinds EmptyBinds = returnDs [] +dsBinds (SingleBind bind) = dsBind [] [] id [] bind -dsBinds auto_scc (ThenBinds binds_1 binds_2) - = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) +dsBinds (ThenBinds binds_1 binds_2) + = andDs (++) (dsBinds binds_1) (dsBinds binds_2) \end{code} @@ -129,7 +130,7 @@ definitions, which don't mention the type variables at all, so making them polymorphic is really overkill. @dsInstBinds@ deals with this case. \begin{code} -dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) +dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) = mapDs mk_poly_private_binder private_binders `thenDs` \ poly_private_binders -> let @@ -148,7 +149,7 @@ dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) -> extendEnvDs inst_env ( - dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds + dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds )) where -- "private_binders" is the list of binders in val_binds @@ -194,7 +195,7 @@ the defn of f' can get floated out, notably if f gets specialised to a particular type for a. \begin{code} -dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) +dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) = -- If there is any non-overloaded polymorphism, make new locals with -- appropriate polymorphism (if null non_overloaded_tyvars @@ -230,7 +231,7 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind extendEnvDs inst_env ( - dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds + dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds )) `thenDs` \ core_binds -> let @@ -240,7 +241,7 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind in mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs -> - returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ] + returnDs (mk_result_bind core_bind_prs) where locals = [local | (local,global) <- local_global_prs] non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars @@ -250,6 +251,14 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind binders = collectTypedBinders val_binds mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id)) + + is_rec_bind = case val_binds of + RecBind _ -> True + NonRecBind _ -> False + + -- Recursion can still be needed if there are type signatures + mk_result_bind prs | is_rec_bind = [Rec prs] + | otherwise = [NonRec binder rhs | (binder,rhs) <- prs] \end{code} @mkSatTyApp id tys@ constructs an expression whose value is (id tys). @@ -385,22 +394,21 @@ some of the binders are of unboxed type. For an explanation of the first three args, see @dsMonoBinds@. \begin{code} -dsBind :: Bool -- Add auto sccs to binds - -> [TyVar] -> [DictVar] -- Abstract wrt these +dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> [(Id,CoreExpr)] -- Inst bindings already dealt with -> TypecheckedBind -> DsM [CoreBinding] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind +dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) - = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> +dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) + = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) - = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> +dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) + = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] \end{code} @@ -424,8 +432,7 @@ of these binders into applications of the new binder to suitable type variables and dictionaries. \begin{code} -dsMonoBinds :: Bool -- True <=> add auto sccs - -> Bool -- True <=> recursive binding group +dsMonoBinds :: Bool -- True <=> recursive binding group -> [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> TypecheckedMonoBinds @@ -439,11 +446,11 @@ dsMonoBinds :: Bool -- True <=> add auto sccs %============================================== \begin{code} -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] +dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1) - (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2) +dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1) + (dsMonoBinds is_rec tyvars dicts binder_subst binds_2) \end{code} @@ -452,31 +459,27 @@ dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 bin %============================================== \begin{code} -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) - = doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] +dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) + = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr) +dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) = dsExpr expr `thenDs` \ core_expr -> - doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] + returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) +dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ let new_fun = binder_subst fun error_string = "function " ++ showForErr fun in matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> - doSccAuto auto_scc [fun] body `thenDs` \ sccd_body -> returnDs [(new_fun, - mkLam tyvars (dicts ++ args) sccd_body)] + mkLam tyvars (dicts ++ args) body)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) +dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr -> - returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)] + returnDs [(binder_subst v, mkLam tyvars dicts body_expr)] \end{code} %============================================== @@ -490,7 +493,7 @@ be empty. (Simple pattern bindings were handled above.) First, the paranoia check. \begin{code} -dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) = panic "Non-empty dict list in for pattern binding" \end{code} @@ -518,11 +521,10 @@ Then we transform to: \end{description} \begin{code} -dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr -> {- KILLED by Sansom. 95/05 -- make *sure* there are no primitive types in the pattern @@ -535,11 +537,11 @@ dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_bi -- we can just use the rhs directly else -} --- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $ +-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] - sccd_body_expr + body_expr where pat_binders = collectTypedPatBinders pat -- NB For a simple tuple pattern, these binders @@ -552,40 +554,3 @@ extra work to benefit only rather unusual constructs like let (_,a,b) = ... in ... \end{verbatim} Better to extend the whole thing for any irrefutable constructor, at least. - -%************************************************************************ -%* * -\subsection[doSccAuto]{Adding automatic sccs} -%* * -%************************************************************************ - -\begin{code} -doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr - -doSccAuto False binders core_expr - = returnDs core_expr - -doSccAuto True [] core_expr -- no binders - = returnDs core_expr - -doSccAuto True _ core_expr@(SCC _ _) -- already sccd - = returnDs core_expr - -doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con - = returnDs core_expr - -doSccAuto True binders core_expr - = let - scc_all = opt_AutoSccsOnAllToplevs - scc_export = not (null export_binders) - - export_binders = filter isExported binders - - scc_binder = head (if scc_all then binders else export_binders) - in - if scc_all || scc_export then - getModuleAndGroupDs `thenDs` \ (mod,grp) -> - returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr) - else - returnDs core_expr -\end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 2efca382c9..96e870e4e8 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), Match(..), Qualifier, HsBinds, HsType, Fixity, + Stmt(..), DoOrListComp(..), Match(..), HsBinds, HsType, Fixity, GRHSsAndBinds ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), @@ -47,16 +47,17 @@ import PprType ( GenType ) import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId ) import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) import TyCon ( isDataTyCon, isNewTyCon ) -import Type ( splitSigmaTy, splitFunTy, typePrimRep, - getAppDataTyConExpandingDicts, getAppTyCon, applyTy, - maybeBoxedPrimType +import Type ( splitSigmaTy, splitFunTy, typePrimRep, + getAppDataTyConExpandingDicts, maybeAppTyCon, getAppTyCon, applyTy, + maybeBoxedPrimType, splitAppTy ) import TysPrim ( voidTy ) -import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, +import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) import Usage ( SYN_IE(UVar) ) +import Maybes ( maybeToBool ) import Util ( zipEqual, pprError, panic, assertPanic ) mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... @@ -75,7 +76,7 @@ around; if we get hits, we use the value accordingly. \begin{code} dsExpr :: TypecheckedHsExpr -> DsM CoreExpr -dsExpr e@(HsVar var) = dsApp e [] +dsExpr e@(HsVar var) = dsId var \end{code} %************************************************************************ @@ -261,18 +262,25 @@ dsExpr expr@(HsCase discrim matches src_loc) matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code ) -dsExpr (ListComp expr quals) - = dsExpr expr `thenDs` \ core_expr -> - dsListComp core_expr quals - dsExpr (HsLet binds expr) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) -dsExpr (HsDoOut stmts then_id zero_id src_loc) +dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc) + | maybeToBool maybe_list_comp -- Special case for list comprehensions + = putSrcLocDs src_loc $ + dsListComp stmts elt_ty + + | otherwise = putSrcLocDs src_loc $ - dsDo then_id zero_id stmts + dsDo do_or_lc stmts return_id then_id zero_id result_ty + where + maybe_list_comp = case maybeAppTyCon result_ty of + Just (tycon, [elt_ty]) | tycon == listTyCon + -> Just elt_ty + other -> Nothing + Just elt_ty = maybe_list_comp dsExpr (HsIf guard_expr then_expr else_expr src_loc) = putSrcLocDs src_loc $ @@ -519,7 +527,7 @@ dsExpr (ClassDictLam dicts methods expr) #ifdef DEBUG -- HsSyn constructs that just shouldn't be here: -dsExpr (HsDo _ _) = panic "dsExpr:HsDo" +dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo" dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList" dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" @@ -565,13 +573,13 @@ dsApp (TyApp expr tys) args -- we might should look out for SectionLs, etc., here, but we don't -dsApp (HsVar v) args - = lookupEnvDs v `thenDs` \ maybe_expr -> - mkAppDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) args - dsApp anything_else args = dsExpr anything_else `thenDs` \ core_expr -> mkAppDs core_expr args + +dsId v + = lookupEnvDs v `thenDs` \ maybe_expr -> + returnDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) \end{code} \begin{code} @@ -611,47 +619,73 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with Basically does the translation given in the Haskell~1.3 report: \begin{code} -dsDo :: Id -- id for: (>>=) m - -> Id -- id for: zero m +dsDo :: DoOrListComp -> [TypecheckedStmt] + -> Id -- id for: return m + -> Id -- id for: (>>=) m + -> Id -- id for: zero m + -> Type -- Element type; the whole expression has type (m t) -> DsM CoreExpr -dsDo then_id zero_id (stmt:stmts) - = case stmt of - ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn - - ExprStmtOut expr locn a b -> - do_expr expr locn `thenDs` \ expr2 -> - ds_rest `thenDs` \ rest -> - newSysLocalDs a `thenDs` \ ignored_result_id -> - dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, - VarArg (mkValLam [ignored_result_id] rest)] - - LetStmt binds -> - dsBinds False binds `thenDs` \ binds2 -> - ds_rest `thenDs` \ rest -> - returnDs (mkCoLetsAny binds2 rest) - - BindStmtOut pat expr locn a b -> - do_expr expr locn `thenDs` \ expr2 -> - let - zero_expr = TyApp (HsVar zero_id) [b] - main_match - = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn)) - the_matches - = if failureFreePat pat - then [main_match] - else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)] - in - matchWrapper DoBindMatch the_matches "`do' statement" - `thenDs` \ (binders, matching_code) -> - dsApp (HsVar then_id) [TyArg a, TyArg b, - VarArg expr2, VarArg (mkValLam binders matching_code)] +dsDo do_or_lc stmts return_id then_id zero_id result_ty + = dsId return_id `thenDs` \ return_ds -> + dsId then_id `thenDs` \ then_ds -> + dsId zero_id `thenDs` \ zero_ds -> + let + (_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b) + + go [ReturnStmt expr] + = dsExpr expr `thenDs` \ expr2 -> + mkAppDs return_ds [TyArg b_ty, VarArg expr2] + + go (GuardStmt expr locn : stmts) + = do_expr expr locn `thenDs` \ expr2 -> + go stmts `thenDs` \ rest -> + mkAppDs zero_ds [TyArg b_ty] `thenDs` \ zero_expr -> + returnDs (mkCoreIfThenElse expr2 rest zero_expr) + + go (ExprStmt expr locn : stmts) + = do_expr expr locn `thenDs` \ expr2 -> + let + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + in + if null stmts then + returnDs expr2 + else + go stmts `thenDs` \ rest -> + newSysLocalDs a_ty `thenDs` \ ignored_result_id -> + mkAppDs then_ds [TyArg a_ty, TyArg b_ty, VarArg expr2, + VarArg (mkValLam [ignored_result_id] rest)] + + go (LetStmt binds : stmts ) + = dsBinds binds `thenDs` \ binds2 -> + go stmts `thenDs` \ rest -> + returnDs (mkCoLetsAny binds2 rest) + + go (BindStmt pat expr locn : stmts) + = putSrcLocDs locn $ + dsExpr expr `thenDs` \ expr2 -> + let + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + zero_expr = TyApp (HsVar zero_id) [b_ty] + main_match = PatMatch pat (SimpleMatch ( + HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)) + the_matches + = if failureFreePat pat + then [main_match] + else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)] + in + matchWrapper DoBindMatch the_matches match_msg + `thenDs` \ (binders, matching_code) -> + mkAppDs then_ds [TyArg a_ty, TyArg b_ty, + VarArg expr2, VarArg (mkValLam binders matching_code)] + in + go stmts + where - ds_rest = dsDo then_id zero_id stmts do_expr expr locn = putSrcLocDs locn (dsExpr expr) -#ifdef DEBUG -dsDo then_expr zero_expr [] = panic "dsDo:[]" -#endif + match_msg = case do_or_lc of + DoStmt -> "`do' statement" + ListComp -> "comprehension" \end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 6b95110a28..c36e0bd58b 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -12,7 +12,8 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop import HsSyn ( GRHSsAndBinds(..), GRHS(..), - HsExpr, HsBinds ) + HsExpr, HsBinds + ) import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) @@ -45,7 +46,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds -> DsM CoreExpr dsGuarded (GRHSsAndBindsOut grhss binds err_ty) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> case can_it_fail of CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) @@ -96,3 +97,4 @@ dsGRHS ty kind pats (GRHS guard expr locn) \end{code} + diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index d7e54ef40a..010d741291 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -36,6 +36,7 @@ outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats) outPatType (RecPat _ ty _) = ty outPatType (LitPat lit ty) = ty outPatType (NPat lit ty _) = ty +outPatType (NPlusKPat _ _ ty _ _) = ty outPatType (DictPat ds ms) = case (length ds_ms) of 0 -> unitTy 1 -> idType (head ds_ms) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 2a396ea7eb..bec2c8ac24 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,8 +11,8 @@ module DsListComp ( dsListComp ) where IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop -import HsSyn ( Qualifier(..), HsExpr, HsBinds ) -import TcHsSyn ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) +import HsSyn ( Stmt(..), HsExpr, HsBinds ) +import TcHsSyn ( SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -37,42 +37,36 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. \begin{code} -dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr +dsListComp :: [TypecheckedStmt] + -> Type -- Type of list elements + -> DsM CoreExpr + +dsListComp quals elt_ty + | not opt_FoldrBuildOn -- Be boring + = deListComp quals nil_expr -dsListComp expr quals - = let - expr_ty = coreExprType expr + | otherwise -- foldr/build lives! + = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] -> + let + alpha_to_alpha = alphaTy `mkFunTy` alphaTy + + n_ty = mkTyVarTy n_tyvar + c_ty = mkFunTys [elt_ty, n_ty] n_ty + g_ty = mkForAllTy alphaTyVar ( + (elt_ty `mkFunTy` alpha_to_alpha) + `mkFunTy` + alpha_to_alpha + ) in - if not opt_FoldrBuildOn then -- be boring - deListComp expr quals (nIL_EXPR expr_ty) - - else -- foldr/build lives! - new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) -> - let - alpha_to_alpha = alphaTy `mkFunTy` alphaTy - - c_ty = mkFunTys [expr_ty, n_ty] n_ty - g_ty = mkForAllTy alphaTyVar ( - (expr_ty `mkFunTy` alpha_to_alpha) - `mkFunTy` - alpha_to_alpha - ) - in - newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - - dfListComp expr expr_ty - c_ty c - n_ty n - quals `thenDs` \ result -> - - returnDs (mkBuild expr_ty n_tyvar c n g result) - where - nIL_EXPR ty = mkCon nilDataCon [] [ty] [] + newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - new_alpha_tyvar :: DsM (TyVar, Type) - new_alpha_tyvar - = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] -> - returnDs (new_ty, mkTyVarTy new_ty) + dfListComp c_ty c + n_ty n + quals `thenDs` \ result -> + + returnDs (mkBuild elt_ty n_tyvar c n g result) + where + nil_expr = mkCon nilDataCon [] [elt_ty] [] \end{code} %************************************************************************ @@ -119,23 +113,24 @@ is the TE translation scheme. Note that we carry around the @L@ list already desugared. @dsListComp@ does the top TE rule mentioned above. \begin{code} -deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr +deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr -deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above - = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list] +deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above + = dsExpr expr `thenDs` \ core_expr -> + mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list] -deListComp expr (FilterQual filt : quals) list -- rule B above - = dsExpr filt `thenDs` \ core_filt -> - deListComp expr quals list `thenDs` \ core_rest -> - returnDs ( mkCoreIfThenElse core_filt core_rest list ) +deListComp (GuardStmt guard locn : quals) list -- rule B above + = dsExpr guard `thenDs` \ core_guard -> + deListComp quals list `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp expr (LetQual binds : quals) list - = dsBinds False binds `thenDs` \ core_binds -> - deListComp expr quals list `thenDs` \ core_rest -> +deListComp (LetStmt binds : quals) list + = dsBinds binds `thenDs` \ core_binds -> + deListComp quals list `thenDs` \ core_rest -> returnDs (mkCoLetsAny core_binds core_rest) -deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above +deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> let u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing @@ -146,27 +141,14 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above res_ty = coreExprType core_list2 h_ty = u1_ty `mkFunTy` res_ty in - newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - `thenDs` \ [h', u1, u2, u3] -> - {- - Make the function h unfoldable by the deforester. - Since it only occurs once in the body, we can't get - an increase in code size by unfolding it. - -} - let - h = if False -- LATER: sw_chkr DoDeforest??? - then panic "deListComp:deforest" - -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest) - else h' - in - -- the "fail" value ... - mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> - - deListComp expr quals core_fail `thenDs` \ rest_expr -> + newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> - matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> - - mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> + -- the "fail" value ... + mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> + deListComp quals core_fail `thenDs` \ rest_expr -> + matchSimply (Var u2) pat res_ty + rest_expr core_fail `thenDs` \ core_match -> + mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> returnDs ( mkCoLetrecAny [ @@ -174,8 +156,8 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above (Lam (ValBinder u1) (Case (Var u1) (AlgAlts - [(nilDataCon, [], core_list2), - (consDataCon, [u2, u3], core_match)] + [(nilDataCon, [], core_list2), + (consDataCon, [u2, u3], core_match)] NoDefault))) )] letrec_body ) @@ -196,29 +178,27 @@ TE << [ e | p <- l , q ] c n = foldr _ b -> b) n l \end{verbatim} \begin{code} -dfListComp :: CoreExpr -- the inside of the comp - -> Type -- the type of the inside - -> Type -> Id -- 'c'; its type and id +dfListComp :: Type -> Id -- 'c'; its type and id -> Type -> Id -- 'n'; its type and id - -> [TypecheckedQual] -- the rest of the qual's + -> [TypecheckedStmt] -- the rest of the qual's -> DsM CoreExpr -dfListComp expr expr_ty c_ty c_id n_ty n_id [] - = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)] +dfListComp c_ty c_id n_ty n_id [ReturnStmt expr] + = dsExpr expr `thenDs` \ core_expr -> + mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)] -dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals) - = dsExpr filt `thenDs` \ core_filt -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals - `thenDs` \ core_rest -> - returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id)) +dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals) + = dsExpr guard `thenDs` \ core_guard -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_guard core_rest (Var n_id)) -dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals) +dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals) -- new in 1.3, local bindings - = dsBinds False binds `thenDs` \ core_binds -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> - returnDs ( mkCoLetsAny core_binds core_rest ) + = dsBinds binds `thenDs` \ core_binds -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs (mkCoLetsAny core_binds core_rest) -dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) +dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals) -- evaluate the two lists = dsExpr list1 `thenDs` \ core_list1 -> @@ -236,7 +216,7 @@ dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) -- build rest of the comprehesion - dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest -> + dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest -> -- build the pattern match matchSimply (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr -> diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi index fd329c0c69..26a0c4b313 100644 --- a/ghc/compiler/deSugar/DsLoop.lhi +++ b/ghc/compiler/deSugar/DsLoop.lhi @@ -26,6 +26,6 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it does -> DsM CoreExpr -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] dsExpr :: TypecheckedHsExpr -> DsM CoreExpr \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index bf3f5f0878..38e567a7ea 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -20,8 +20,11 @@ module DsMonad ( SYN_IE(DsIdEnv), lookupId, - dsShadowError, - DsMatchContext(..), DsMatchKind(..), pprDsWarnings + dsShadowWarn, dsIncompleteWarn, + DsWarnings(..), + DsMatchContext(..), DsMatchKind(..), pprDsWarnings, + DsWarnFlavour -- Nuke with 1.4 + ) where IMP_Ubiq() @@ -60,8 +63,9 @@ type DsM result = -> DsWarnings -> (result, DsWarnings) -type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are - -- completely shadowed +type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) + -- The desugarer reports matches which are + -- completely shadowed or incomplete patterns {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -181,9 +185,13 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a putSrcLocDs new_loc expr us old_loc mod_and_grp env warns = expr us new_loc mod_and_grp env warns -dsShadowError :: DsMatchContext -> DsM () -dsShadowError cxt us loc mod_and_grp env warns - = ((), warns `snocBag` cxt) +dsShadowWarn :: DsMatchContext -> DsM () +dsShadowWarn cxt us loc mod_and_grp env warns + = ((), warns `snocBag` (Shadowed, cxt)) + +dsIncompleteWarn :: DsMatchContext -> DsM () +dsIncompleteWarn cxt us loc mod_and_grp env warns + = ((), warns `snocBag` (Incomplete, cxt)) \end{code} \begin{code} @@ -237,9 +245,12 @@ lookupId env id %************************************************************************ \begin{code} +data DsWarnFlavour = Shadowed | Incomplete deriving () + data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext + deriving () data DsMatchKind = FunMatch Id @@ -247,23 +258,31 @@ data DsMatchKind | LambdaMatch | PatBindMatch | DoBindMatch + deriving () -pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty +pprDsWarnings :: PprStyle -> DsWarnings -> Pretty pprDsWarnings sty warns - = ppAboves (map pp_cxt (bagToList warns)) + = ppAboves (map pp_warn (bagToList warns)) where - pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what") - pp_cxt (DsMatchContext kind pats loc) - = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) - 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:")) + pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), + case flavour of + Shadowed -> ppPStr SLIT("shadowed") + Incomplete -> ppPStr SLIT("possibly incomplete")] + + pp_warn (flavour, DsMatchContext kind pats loc) + = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) + 4 (ppHang msg 4 (pp_match kind pats)) + where + msg = case flavour of + Shadowed -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped") + Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns") pp_match (FunMatch fun) pats - = ppHang (ppr sty fun) - 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")]) + = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a case alternative:")) + = ppHang (ppPStr SLIT("in a group of case alternative beginning:")) 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) pp_match PatBindMatch pats diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index ff2ec5fe45..3fdc1d3c9a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -31,7 +31,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity, - Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) + Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -46,21 +46,20 @@ import Id ( idType, dataConArgTys, -- pprId{-ToDo:rm-}, SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) +import PprType ( GenType, GenTyVar ) import TyCon ( isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, - mkTheta, isUnboxedType, applyTyCon, getAppTyCon + mkTheta, isUnboxedType, applyTyCon, getAppTyCon, + GenType {- instances -} ) +import TyVar ( GenTyVar {- instances -} ) import TysPrim ( voidTy ) import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import Unique ( Unique ) import Usage ( SYN_IE(UVar) ) import SrcLoc ( SrcLoc {- instance Outputable -} ) ---import PprCore{-ToDo:rm-} ---import PprType--ToDo:rm ---import Pretty--ToDo:rm ---import TyVar--ToDo:rm ---import Unique--ToDo:rm \end{code} %************************************************************************ @@ -316,7 +315,7 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = getSrcLocDs `thenDs` \ src_loc -> let - full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg]) + full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr "|", ppStr msg]) msg_lit = NoRepStr (_PK_ full_msg) in returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) @@ -356,7 +355,7 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr = if is_simple_tuple_pat pat then mkTupleBind tyvars [] locals_and_globals val_expr else - mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg -> + mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg -> matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> mkTupleBind tyvars [] locals_and_globals tuple_expr where @@ -369,6 +368,8 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr is_var_pat (VarPat v) = True is_var_pat other = False -- Even wild-card patterns aren't acceptable + + pat_string = ppShow 80 (ppr PprForUser pat) \end{code} We're about to match against some patterns. We want to make some diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c822765110..7fb28b1c05 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -153,31 +153,27 @@ And gluing the ``success expressions'' together isn't quite so pretty. \begin{code} match [] eqns_info shadows - = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) -> + = complete_matches eqns_info (any eqn_cant_fail shadows) + where + complete_matches [eqn] is_shadowed + = complete_match eqn is_shadowed + + complete_matches (eqn:eqns) is_shadowed + = complete_match eqn is_shadowed `thenDs` \ match_result1 -> + complete_matches eqns (is_shadowed || eqn_cant_fail eqn) `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 -- If at this stage we find that at least one of the shadowing -- equations is guaranteed not to fail, then warn of an overlapping pattern - if not (all shadow_can_fail shadows) then - dsShadowError cxt `thenDs` \ _ -> - returnDs match_result - else - returnDs match_result - - where - pin_eqns [EqnInfo [] match_result] = returnDs match_result - -- Last eqn... can't have pats ... - - pin_eqns (EqnInfo [] match_result1 : more_eqns) - = pin_eqns more_eqns `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 + complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed + | is_shadowed = dsShadowWarn cxt `thenDs` \ _ -> + returnDs match_result - pin_eqns other_pat = panic "match: pin_eqns" + | otherwise = returnDs match_result - shadow_can_fail :: EquationInfo -> Bool - - shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True - shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False - shadow_can_fail other = panic "match:shadow_can_fail" + eqn_cant_fail :: EquationInfo -> Bool + eqn_cant_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = False + eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True \end{code} %************************************************************************ @@ -253,6 +249,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. Removing lazy (irrefutable) patterns (you don't want to know...). \item Converting explicit tuple- and list-pats into ordinary @ConPats@. +\item +Convert the literal pat "" to []. \end{itemize} The result of this tidying is that the column of patterns will include @@ -395,6 +393,7 @@ tidy1 v pat@(LitPat lit lit_ty) match_result -- NPats: we *might* be able to replace these w/ a simpler form + tidy1 v pat@(NPat lit lit_ty _) match_result = returnDs (better_pat, match_result) where @@ -405,6 +404,10 @@ tidy1 v pat@(NPat lit lit_ty _) match_result | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + + -- Convert the literal pattern "" to the constructor pattern []. + | null_str_lit lit = ConPat nilDataCon lit_ty [] + | otherwise = pat mk_int (HsInt i) = HsIntPrim i @@ -425,6 +428,9 @@ tidy1 v pat@(NPat lit lit_ty _) match_result mk_double (HsFrac f) = HsDoublePrim f mk_double l@(HsLitLit s) = l + null_str_lit (HsString s) = _NULL_ s + null_str_lit other_lit = False + -- and everything else goes through unchanged... tidy1 v non_interesting_pat match_result @@ -608,7 +614,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string matchWrapper kind [(GRHSMatch (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ([], mkCoLetsAny core_binds core_expr) @@ -622,8 +628,14 @@ matchWrapper kind matches error_string match new_vars eqns_info [] `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> + -- Check for incomplete pattern match + (case match_result of + MatchResult CanFail result_ty match_fn cxt -> dsIncompleteWarn cxt + other -> returnDs () + ) `thenDs` \ _ -> + + extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) \end{code} @@ -664,8 +676,8 @@ matchSimply scrut_expr pat result_ty result_expr msg extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr = returnDs (match_fn (error "It can't fail!")) -extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr - = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> +extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr + = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails)) \end{code} @@ -699,7 +711,7 @@ flattenMatches kind (match : matches) = flatten_match (pat:pats_so_far) match flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsGRHSs ty kind pats grhss `thenDs` \ match_result -> returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where @@ -707,12 +719,14 @@ flattenMatches kind (match : matches) flatten_match pats_so_far (SimpleMatch expr) = dsExpr expr `thenDs` \ core_expr -> + getSrcLocDs `thenDs` \ locn -> returnDs (EqnInfo pats (MatchResult CantFail (coreExprType core_expr) (\ ignore -> core_expr) - NoMatchContext)) - -- The NoMatchContext is just a place holder. In a simple match, - -- the matching can't fail, so we won't generate an error message. - where - pats = reverse pats_so_far -- They've accumulated in reverse order + (DsMatchContext kind pats locn))) + + -- the matching can't fail, so we won't generate an error message. + where + pats = reverse pats_so_far -- They've accumulated in reverse order + \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index a4ed52d685..c7e4bc1d9c 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -12,11 +12,12 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, - Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) + Match, HsBinds, Stmt(..), DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedPat) ) -import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) ) +import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr(..), GenCoreBinding(..) ) +import Id ( GenId {- instance Eq -} ) import DsMonad import DsUtils @@ -54,9 +55,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps match_prims_used vars eqns_info@(EqnInfo ((LitPat literal lit_ty):ps1) _ : eqns) shadows = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit literal eqns_info + = partitionEqnsByLit Nothing literal eqns_info (shifted_shadows_for_this_lit, shadows_not_for_this_lit) - = partitionEqnsByLit literal shadows + = partitionEqnsByLit Nothing literal shadows in -- recursive call to make other alts... match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ rest_of_alts -> @@ -85,9 +86,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit literal eqns_info + = partitionEqnsByLit Nothing literal eqns_info (shifted_shadows_for_this_lit, shadows_not_for_this_lit) - = partitionEqnsByLit literal shadows + = partitionEqnsByLit Nothing literal shadows in dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr -> match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> @@ -111,12 +112,42 @@ We generate: <try-next-pattern-or-whatever> \end{verbatim} + +\begin{code} +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty ge sub):ps1) _ : eqns) shadows + = let + (shifted_eqns_for_this_lit, eqns_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k eqns_info + (shifted_shadows_for_this_lit, shadows_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k shadows + in + match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> + + dsExpr (HsApp ge (HsVar var)) `thenDs` \ ge_expr -> + dsExpr (HsApp sub (HsVar var)) `thenDs` \ nminusk_expr -> + + mkGuardedMatchResult + ge_expr + (mkCoLetsMatchResult [NonRec master_n nminusk_expr] inner_match_result) + `thenDs` \ match_result1 -> + + if (null eqns_not_for_this_lit) + then + returnDs match_result1 + else + matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 +\end{code} + Given a blob of LitPats/NPats, we want to split them into those that are ``same''/different as one we are looking at. We need to know whether we're looking at a LitPat/NPat, and what literal we're after. \begin{code} -partitionEqnsByLit :: HsLit +partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v + -- is the "master" variable; + -- Nothing for NPats and LitPats + -> HsLit -> [EquationInfo] -> ([EquationInfo], -- These ones are for this lit, AND -- they've been "shifted" by stripping @@ -125,27 +156,34 @@ partitionEqnsByLit :: HsLit -- are exactly as fed in. ) -partitionEqnsByLit lit eqns +partitionEqnsByLit nPlusK lit eqns = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) - (unzip (map (partition_eqn lit) eqns)) + (unzip (map (partition_eqn nPlusK lit) eqns)) where - partition_eqn :: HsLit -> EquationInfo -> + partition_eqn :: Maybe Id -> HsLit -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) - partition_eqn lit (EqnInfo (LitPat k _ : remaining_pats) match_result) + partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result) | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) - -- NB the pattern is stripped off thhe EquationInfo + -- NB the pattern is stripped off the EquationInfo - partition_eqn lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) + partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) - -- NB the pattern is stripped off thhe EquationInfo + -- NB the pattern is stripped off the EquationInfo + + partition_eqn (Just master_n) lit (EqnInfo (NPlusKPat n k _ _ _ : remaining_pats) match_result) + | lit `eq_lit` k = (Just (EqnInfo remaining_pats new_match_result), Nothing) + -- NB the pattern is stripped off the EquationInfo + where + new_match_result | master_n == n = match_result + | otherwise = mkCoLetsMatchResult [NonRec n (Var master_n)] match_result -- Wild-card patterns, which will only show up in the shadows, go into both groups - partition_eqn lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) + partition_eqn nPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) = (Just (EqnInfo remaining_pats match_result), Just eqn) -- Default case; not for this pattern - partition_eqn lit eqn = (Nothing, Just eqn) + partition_eqn nPlusK lit eqn = (Nothing, Just eqn) -- ToDo: meditate about this equality business... diff --git a/ghc/compiler/hsSyn/HsBasic.lhs b/ghc/compiler/hsSyn/HsBasic.lhs index 114721a707..b6bf85e340 100644 --- a/ghc/compiler/hsSyn/HsBasic.lhs +++ b/ghc/compiler/hsSyn/HsBasic.lhs @@ -92,9 +92,9 @@ instance Outputable Fixity where ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] instance Outputable FixityDirection where - ppr sty InfixL = ppStr "infixl" - ppr sty InfixR = ppStr "infixr" - ppr sty InfixN = ppStr "infix" + ppr sty InfixL = ppPStr SLIT("infixl") + ppr sty InfixR = ppPStr SLIT("infixr") + ppr sty InfixN = ppPStr SLIT("infix") instance Eq Fixity where -- Used to determine if two fixities conflict (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index fd1f1f3ec0..8a0232721b 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -68,7 +68,7 @@ data HsBinds tyvar uvar id pat -- binders and bindees | AbsBinds -- Binds abstraction; TRANSLATION [tyvar] [id] -- Dicts - [(id, id)] -- (old, new) pairs + [(id, id)] -- (momonmorphic, polymorphic) pairs [(id, HsExpr tyvar uvar id pat)] -- local dictionaries (Bind tyvar uvar id pat) -- "the business end" @@ -80,6 +80,31 @@ data HsBinds tyvar uvar id pat -- binders and bindees -- of this last construct.) \end{code} +What AbsBinds means +~~~~~~~~~~~~~~~~~~~ + AbsBinds [a,b] + [d1,d2] + [(fm,fp), (gm,gp)] + [d3 = d1, + d4 = df d2] + BIND +means + + fp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in fm + + gp = ...same again, with gm instead of fm + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in (fm,gm) + \begin{code} nullBinds :: HsBinds tyvar uvar id pat -> Bool @@ -129,9 +154,9 @@ data Sig name (HsType name) SrcLoc - | ClassOpSig name -- class-op sigs have different pragmas + | ClassOpSig name -- Selector name + name -- Default-method name (HsType name) - (ClassOpPragmas name) -- only interface ones have pragmas SrcLoc | SpecSig name -- specialise a function or datatype ... @@ -157,27 +182,28 @@ instance (NamedThing name, Outputable name) => Outputable (Sig name) where = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")]) 4 (ppr sty ty) - ppr sty (ClassOpSig var ty pragmas _) + ppr sty (ClassOpSig var _ ty _) = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) - 4 (ppHang (ppr sty ty) - 4 (ifnotPprForUser sty (ppr sty pragmas))) + 4 (ppr sty ty) ppr sty (DeforestSig var _) = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var]) - 4 (ppStr "#-}") + 4 (ppStr "#-") ppr sty (SpecSig var ty using _) - = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")]) + = ppHang (ppCat [ppStr "{-# SPECIALIZE", pprNonSym sty var, ppPStr SLIT("::")]) + 4 (ppCat [ppr sty ty, pp_using using, ppStr "#-}"]) + where pp_using Nothing = ppNil pp_using (Just me) = ppCat [ppChar '=', ppr sty me] ppr sty (InlineSig var _) - = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")] + + = ppCat [ppStr "{-# INLINE", pprNonSym sty var, ppStr "#-}"] ppr sty (MagicUnfoldingSig var str _) - = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")] + = ppCat [ppStr "{-# MAGIC_UNFOLDING", pprNonSym sty var, ppPStr str, ppStr "#-}"] \end{code} %************************************************************************ @@ -215,10 +241,10 @@ instance (NamedThing id, Outputable id, Outputable pat, Outputable (Bind tyvar uvar id pat) where ppr sty EmptyBind = ppNil ppr sty (NonRecBind binds) - = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}")) + = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- nonrec -}"))) (ppr sty binds) ppr sty (RecBind binds) - = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}")) + = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- rec -}"))) (ppr sty binds) \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 3a240733fc..8e60262755 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -66,15 +66,14 @@ data UfPrimOp name data UfCoercion name = UfIn name | UfOut name data UfAlts name - = UfAlgAlts [(name, [UfBinder name], UfExpr name)] + = UfAlgAlts [(name, [name], UfExpr name)] (UfDefault name) | UfPrimAlts [(Literal, UfExpr name)] (UfDefault name) data UfDefault name = UfNoDefault - | UfBindDefault (UfBinder name) - (UfExpr name) + | UfBindDefault name (UfExpr name) data UfBinding name = UfNonRec (UfBinder name) @@ -105,15 +104,15 @@ instance Outputable name => Outputable (UfExpr name) where ppr sty (UfLit l) = ppr sty l ppr sty (UfCon c as) - = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"] + = ppCat [ppStr "UfCon", ppr sty c, ppr sty as, ppChar ')'] ppr sty (UfPrim o as) - = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"] + = ppCat [ppStr "UfPrim", ppr sty o, ppr sty as, ppChar ')'] ppr sty (UfLam b body) - = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body] + = ppCat [ppChar '\\', ppr sty b, ppPStr SLIT("->"), ppr sty body] ppr sty (UfApp fun (UfTyArg ty)) - = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty] + = ppCat [ppr sty fun, ppChar '@', pprParendHsType sty ty] ppr sty (UfApp fun (UfLitArg lit)) = ppCat [ppr sty fun, ppr sty lit] @@ -122,34 +121,36 @@ instance Outputable name => Outputable (UfExpr name) where = ppCat [ppr sty fun, ppr sty var] ppr sty (UfCase scrut alts) - = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"] + = ppCat [ppPStr SLIT("case"), ppr sty scrut, ppPStr SLIT("of {"), pp_alts alts, ppChar '}'] where pp_alts (UfAlgAlts alts deflt) = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] where - pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs] + pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs] pp_alts (UfPrimAlts alts deflt) = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] where - pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs] + pp_alt (l,rhs) = ppCat [ppr sty l, ppr_arrow, ppr sty rhs] pp_deflt UfNoDefault = ppNil - pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs] + pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppr_arrow, ppr sty rhs] + + ppr_arrow = ppPStr SLIT("->") ppr sty (UfLet (UfNonRec b rhs) body) - = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body] + = ppCat [ppPStr SLIT("let"), ppr sty b, ppEquals, ppr sty rhs, ppPStr SLIT("in"), ppr sty body] ppr sty (UfLet (UfRec pairs) body) - = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body] + = ppCat [ppPStr SLIT("letrec {"), ppInterleave ppSemi (map pp_pair pairs), ppPStr SLIT("} in"), ppr sty body] where pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs] ppr sty (UfSCC uf_cc body) - = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body] + = ppCat [ppPStr SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body] instance Outputable name => Outputable (UfPrimOp name) where ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty) = let - before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ") + before = ppPStr (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) after = if is_casm then ppStr "'' " else ppSP in ppBesides [before, ppPStr str, after, @@ -165,8 +166,8 @@ instance Outputable name => Outputable (UfArg name) where ppr sty (UfUsageArg name) = ppr sty name instance Outputable name => Outputable (UfBinder name) where - ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppStr "::", ppr sty ty] - ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind] + ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty ty] + ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty kind] ppr sty (UfUsageBinder name) = ppr sty name \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 9f9073560e..d4f6628b68 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -31,7 +31,7 @@ import Outputable ( interppSP, interpp'SP, ) import Pretty import SrcLoc ( SrcLoc ) -import PprStyle ( PprStyle(..) ) +import PprStyle ( PprStyle(..), ifaceStyle ) \end{code} @@ -71,6 +71,10 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (ValD binds) = ppr sty binds ppr sty (DefD def) = ppr sty def ppr sty (InstD inst) = ppr sty inst + +-- In interfaces, top-level binders are printed without their "Module." prefix +ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr) + | otherwise = ppr sty bndr \end{code} @@ -143,12 +147,12 @@ instance (NamedThing name, Outputable name) derivings pp_decl_head sty str pp_context tycon tyvars - = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon), + = ppCat [ppPStr str, pp_context, ppr_top_binder sty tycon, interppSP sty tyvars, ppPStr SLIT("=")] pp_condecls sty [] = ppNil -- Curious! pp_condecls sty (c:cs) - = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs) + = ppSep (ppr sty c : map (\ c -> ppBeside (ppPStr SLIT("| ")) (ppr sty c)) cs) pp_tydecl sty pp_head pp_decl_rhs derivings = ppHang pp_head 4 (ppSep [ @@ -215,25 +219,26 @@ data BangType name instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where ppr sty (ConDecl con tys _) - = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)] + = ppCat [ppr_top_binder sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] -- We print ConOpDecls in prefix form in interface files - ppr PprInterface (ConOpDecl ty1 op ty2 _) - = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2] ppr sty (ConOpDecl ty1 op ty2 _) - = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2] + | ifaceStyle sty + = ppCat [ppr_top_binder sty op, ppr_bang sty ty1, ppr_bang sty ty2] + | otherwise + = ppCat [ppr_bang sty ty1, ppr_top_binder sty op, ppr_bang sty ty2] ppr sty (NewConDecl con ty _) - = ppCat [ppr sty (getOccName con), pprParendHsType sty ty] + = ppCat [ppr_top_binder sty con, pprParendHsType sty ty] ppr sty (RecConDecl con fields _) - = ppCat [ppr sty (getOccName con), + = ppCat [ppr_top_binder sty con, ppCurlies (ppInterleave pp'SP (map pp_field fields)) ] where - pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns), + pp_field (ns, ty) = ppCat [ppCat (map (ppr_top_binder sty) ns), ppPStr SLIT("::"), ppr_bang sty ty] -ppr_bang sty (Banged ty) = ppBeside (ppStr "! ") (pprParendHsType sty ty) +ppr_bang sty (Banged ty) = ppBeside (ppPStr SLIT("! ")) (pprParendHsType sty ty) -- The extra space helps the lexical analyser that lexes -- interface files; it doesn't make the rigid operator/identifier -- distinction, so "!a" is a valid identifier so far as it is concerned @@ -267,16 +272,16 @@ instance (NamedThing name, Outputable name, Outputable pat, = top_matter | iface_style -- All on one line (for now at least) - = ppCat [top_matter, ppStr "where", + = ppCat [top_matter, ppPStr SLIT("where"), ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)] | otherwise -- Laid out - = ppSep [ppCat [top_matter, ppStr "where {"], + = ppSep [ppCat [top_matter, ppPStr SLIT("where {")], ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods) - `ppBeside` ppStr "}")] + `ppBeside` ppChar '}')] where - top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context, - ppr sty (getOccName clas), ppr sty tyvar] + top_matter = ppCat [ppPStr SLIT("class"), pp_context_and_arrow sty context, + ppr_top_binder sty clas, ppr sty tyvar] pp_sigs = map (ppr sty) sigs pp_methods = ppr sty methods iface_style = case sty of {PprInterface -> True; other -> False} @@ -311,10 +316,10 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc) | case sty of { PprInterface -> True; other -> False} || nullMonoBinds binds && null uprags - = ppCat [ppStr "instance", ppr sty inst_ty] + = ppCat [ppPStr SLIT("instance"), ppr sty inst_ty] | otherwise - = ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"], + = ppAboves [ppCat [ppPStr SLIT("instance"), ppr sty inst_ty, ppPStr SLIT("where")], ppNest 4 (ppr sty uprags), ppNest 4 (ppr sty binds) ] \end{code} @@ -372,7 +377,7 @@ data IfaceSig name instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where ppr sty (IfaceSig var ty _ _) - = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) + = ppHang (ppCat [ppr_top_binder sty var, ppPStr SLIT("::")]) 4 (ppr sty ty) data HsIdInfo name diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index b08debd8a1..936c61225a 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -82,17 +82,18 @@ data HsExpr tyvar uvar id pat | HsLet (HsBinds tyvar uvar id pat) -- let(rec) (HsExpr tyvar uvar id pat) - | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts + | HsDo DoOrListComp + [Stmt tyvar uvar id pat] -- "do":one or more stmts SrcLoc - | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts - id -- id for >>=, types applied - id -- id for zero, typed applied + | HsDoOut DoOrListComp + [Stmt tyvar uvar id pat] -- "do":one or more stmts + id -- id for return + id -- id for >>= + id -- id for zero + (GenType tyvar uvar) -- Type of the whole expression SrcLoc - | ListComp (HsExpr tyvar uvar id pat) -- list comprehension - [Qualifier tyvar uvar id pat] -- at least one Qualifier - | ExplicitList -- syntactic list [HsExpr tyvar uvar id pat] | ExplicitListOut -- TRANSLATION @@ -200,7 +201,7 @@ pprExpr sty (HsLit lit) = ppr sty lit pprExpr sty (HsLitOut lit _) = ppr sty lit pprExpr sty (HsLam match) - = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)] + = ppCat [ppChar '\\', ppNest 2 (pprMatch sty True match)] pprExpr sty expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in @@ -236,8 +237,8 @@ pprExpr sty (SectionL expr op) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op]) - 4 (ppCat [pp_expr, ppStr "x_ )"]) + pp_prefixly = ppHang (ppCat [ppStr " \\ x_ ->", ppr sty op]) + 4 (ppCat [pp_expr, ppPStr SLIT("x_ )")]) pp_infixly v = ppSep [ ppBeside ppLparen pp_expr, ppBeside (ppr sty v) ppRparen ] @@ -274,14 +275,8 @@ pprExpr sty (HsLet binds expr) = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds), ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)] -pprExpr sty (HsDo stmts _) - = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) -pprExpr sty (HsDoOut stmts _ _ _) - = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) - -pprExpr sty (ListComp expr quals) - = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) - 4 (ppSep [interpp'SP sty quals, ppRbrack]) +pprExpr sty (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp sty stmts +pprExpr sty (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp sty stmts pprExpr sty (ExplicitList exprs) = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)) @@ -311,11 +306,11 @@ pprExpr sty (ArithSeqOut expr info) PprForUser -> ppBracket (ppr sty info) _ -> - ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack] + ppBesides [ppLbrack, ppParens (ppr sty expr), ppSP, ppr sty info, ppRbrack] pprExpr sty (CCall fun args _ is_asm result_ty) = ppHang (if is_asm - then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] + then ppBesides [ppPStr SLIT("_casm_ ``"), ppPStr fun, ppPStr SLIT("''")] else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) 4 (ppSep (map (pprParendExpr sty) args)) @@ -324,7 +319,7 @@ pprExpr sty (HsSCC label expr) pprParendExpr sty expr ] pprExpr sty (TyLam tyvars expr) - = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) + = ppHang (ppCat [ppPStr SLIT("/\\"), interppSP sty tyvars, ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (TyApp expr [ty]) @@ -335,7 +330,7 @@ pprExpr sty (TyApp expr tys) 4 (ppBracket (interpp'SP sty tys)) pprExpr sty (DictLam dictvars expr) - = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"]) + = ppHang (ppCat [ppPStr SLIT("\\{-dict-}"), interppSP sty dictvars, ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (DictApp expr [dname]) @@ -346,10 +341,10 @@ pprExpr sty (DictApp expr dnames) 4 (ppBracket (interpp'SP sty dnames)) pprExpr sty (ClassDictLam dicts methods expr) - = ppHang (ppCat [ppStr "\\{-classdict-}", + = ppHang (ppCat [ppPStr SLIT("\\{-classdict-}"), ppBracket (interppSP sty dicts), ppBracket (interppSP sty methods), - ppStr "->"]) + ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (Dictionary dicts methods) @@ -402,27 +397,43 @@ pp_rbinds sty thing rbinds 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds))) where pp_rbind PprForUser (v, _, True) = ppr PprForUser v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e] + pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppChar '=', ppr sty e] \end{code} %************************************************************************ %* * -\subsection{Do stmts} +\subsection{Do stmts and list comprehensions} %* * %************************************************************************ \begin{code} +data DoOrListComp = DoStmt | ListComp + +pprDo DoStmt sty stmts + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) +pprDo ListComp sty stmts + = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) + 4 (ppSep [interpp'SP sty quals, ppRbrack]) + where + ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps + quals = init stmts +\end{code} + +\begin{code} data Stmt tyvar uvar id pat = BindStmt pat (HsExpr tyvar uvar id pat) SrcLoc - | ExprStmt (HsExpr tyvar uvar id pat) - SrcLoc + | LetStmt (HsBinds tyvar uvar id pat) - - -- Translations; the types are the "a" and "b" types of the monad. - | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) - | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) + + | GuardStmt (HsExpr tyvar uvar id pat) -- List comps only + SrcLoc + + | ExprStmt (HsExpr tyvar uvar id pat) -- Do stmts only + SrcLoc + + | ReturnStmt (HsExpr tyvar uvar id pat) -- List comps only, at the end \end{code} \begin{code} @@ -430,15 +441,15 @@ instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (Stmt tyvar uvar id pat) where ppr sty (BindStmt pat expr _) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] + = ppCat [ppr sty pat, ppPStr SLIT("<-"), ppr sty expr] ppr sty (LetStmt binds) = ppCat [ppPStr SLIT("let"), ppr sty binds] ppr sty (ExprStmt expr _) = ppr sty expr - ppr sty (BindStmtOut pat expr _ _ _) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (ExprStmtOut expr _ _ _) + ppr sty (GuardStmt expr _) = ppr sty expr + ppr sty (ReturnStmt expr) + = ppCat [ppPStr SLIT("return"), ppr sty expr] \end{code} %************************************************************************ @@ -471,24 +482,3 @@ instance (NamedThing id, Outputable id, Outputable pat, pp_dotdot = ppPStr SLIT(" .. ") \end{code} - -``Qualifiers'' in list comprehensions: -\begin{code} -data Qualifier tyvar uvar id pat - = GeneratorQual pat - (HsExpr tyvar uvar id pat) - | LetQual (HsBinds tyvar uvar id pat) - | FilterQual (HsExpr tyvar uvar id pat) -\end{code} - -\begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Qualifier tyvar uvar id pat) where - ppr sty (GeneratorQual pat expr) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (LetQual binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (FilterQual expr) - = ppr sty expr -\end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index da42d1ce89..aff67627c1 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -50,6 +50,9 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) + | NPlusKPatIn name -- n+k pattern + HsLit + -- We preserve prefix negation and parenthesis for the precedence parser. | NegPatIn (InPat name) -- negated pattern @@ -104,6 +107,15 @@ data OutPat tyvar uvar id (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- of type t -> Bool; detects match + | NPlusKPat id + HsLit -- Same reason as for LitPat + -- (This could be an Integer, but then + -- it's harder to partitionEqnsByLit + -- in the desugarer.) + (GenType tyvar uvar) -- Type of pattern, t + (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> Bool; detects match + (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> t; subtracts k + | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods @@ -115,7 +127,7 @@ instance (Outputable name, NamedThing name) => Outputable (InPat name) where pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty -pprInPat sty (WildPatIn) = ppStr "_" +pprInPat sty (WildPatIn) = ppChar '_' pprInPat sty (VarPatIn var) = ppr sty var pprInPat sty (LitPatIn s) = ppr sty s pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) @@ -151,12 +163,14 @@ pprInPat sty (ListPatIn pats) = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] pprInPat sty (TuplePatIn pats) = ppParens (interpp'SP sty pats) +pprInPat sty (NPlusKPatIn n k) + = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] pprInPat sty (RecPatIn con rpats) = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] where pp_rpat PprForUser (v, _, True) = ppr PprForUser v - pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p] \end{code} \begin{code} @@ -193,10 +207,12 @@ pprOutPat sty (RecPat con ty rpats) = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] where pp_rpat PprForUser (v, _, True) = ppr PprForUser v - pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p] pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more +pprOutPat sty (NPlusKPat n k ty e1 e2) -- ToDo: print more + = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] pprOutPat sty (DictPat dicts methods) = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], @@ -279,10 +295,11 @@ isConPat other = False patsAreAllLits :: [OutPat a b c] -> Bool patsAreAllLits pat_list = all isLitPat pat_list -isLitPat (AsPat _ pat) = isLitPat pat -isLitPat (LitPat _ _) = True -isLitPat (NPat _ _ _) = True -isLitPat other = False +isLitPat (AsPat _ pat) = isLitPat pat +isLitPat (LitPat _ _) = True +isLitPat (NPat _ _ _) = True +isLitPat (NPlusKPat _ _ _ _ _) = True +isLitPat other = False \end{code} This function @collectPatBinders@ works with the ``collectBinders'' @@ -296,6 +313,7 @@ collectPatBinders (VarPatIn var) = [var] collectPatBinders (LitPatIn _) = [] collectPatBinders (LazyPatIn pat) = collectPatBinders pat collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat +collectPatBinders (NPlusKPatIn n _) = [n] collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2 collectPatBinders (NegPatIn pat) = collectPatBinders pat diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index 1337b4d83d..c8a7112a61 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -173,34 +173,34 @@ Some instances for printing (just for debugging, really) instance Outputable name => Outputable (ClassPragmas name) where ppr sty NoClassPragmas = ppNil ppr sty (SuperDictPragmas sdsel_prags) - = ppAbove (ppStr "{-superdict pragmas-}") + = ppAbove (ppPStr SLIT("{-superdict pragmas-}")) (ppr sty sdsel_prags) instance Outputable name => Outputable (ClassOpPragmas name) where ppr sty NoClassOpPragmas = ppNil ppr sty (ClassOpPragmas op_prags defm_prags) - = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags]) - (ppCat [ppStr "{-defm-}", ppr sty defm_prags]) + = ppAbove (ppCat [ppPStr SLIT("{-meth-}"), ppr sty op_prags]) + (ppCat [ppPStr SLIT("{-defm-}"), ppr sty defm_prags]) instance Outputable name => Outputable (InstancePragmas name) where ppr sty NoInstancePragmas = ppNil ppr sty (SimpleInstancePragma dfun_pragmas) - = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas] + = ppCat [ppPStr SLIT("{-dfun-}"), ppr sty dfun_pragmas] ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs) - = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas]) + = ppAbove (ppCat [ppPStr SLIT("{-constm-}"), ppr sty dfun_pragmas]) (ppAboves (map pp_pair name_pragma_pairs)) where pp_pair (n, prags) = ppCat [ppr sty n, ppEquals, ppr sty prags] ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) - = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas]) + = ppAbove (ppCat [ppPStr SLIT("{-spec'd-}"), ppr sty dfun_pragmas]) (ppAboves (map pp_info spec_pragma_info)) where pp_info (ty_maybes, num_dicts, prags) = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack, ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags] - pp_ty Nothing = ppStr "_N_" + pp_ty Nothing = ppPStr SLIT("_N_") pp_ty (Just t)= ppr sty t instance Outputable name => Outputable (GenPragmas name) where @@ -211,29 +211,29 @@ instance Outputable name => Outputable (GenPragmas name) where pp_specs specs] where pp_arity Nothing = ppNil - pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i) + pp_arity (Just i) = ppBeside (ppPStr SLIT("ARITY=")) (ppInt i) pp_upd Nothing = ppNil pp_upd (Just u) = ppUpdateInfo sty u pp_str NoImpStrictness = ppNil pp_str (ImpStrictness is_bot demands wrkr_prags) - = ppBesides [ppStr "IS_BOT=", ppr sty is_bot, - ppStr "STRICTNESS=", ppStr (showList demands ""), - ppStr " {", ppr sty wrkr_prags, ppStr "}"] + = ppBesides [ppPStr SLIT("IS_BOT="), ppr sty is_bot, + ppPStr SLIT("STRICTNESS="), ppStr (showList demands ""), + ppPStr SLIT(" {"), ppr sty wrkr_prags, ppChar '}'] - pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING" - pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m) - pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core) + pp_unf NoImpUnfolding = ppPStr SLIT("NO_UNFOLDING") + pp_unf (ImpMagicUnfolding m) = ppBeside (ppPStr SLIT("MAGIC=")) (ppPStr m) + pp_unf (ImpUnfolding g core) = ppBeside (ppPStr SLIT("UNFOLD=")) (ppr sty core) pp_specs [] = ppNil pp_specs specs - = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"] + = ppBesides [ppPStr SLIT("SPECS=["), ppInterleave ppSP (map pp_spec specs), ppChar ']'] where pp_spec (ty_maybes, num_dicts, gprags) = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags] - pp_MaB Nothing = ppStr "_N_" + pp_MaB Nothing = ppPStr SLIT("_N_") pp_MaB (Just x) = ppr sty x \end{code} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 425ee72ab2..195809dc34 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -104,7 +104,7 @@ instance (Outputable name) => Outputable (HsType name) where instance (Outputable name) => Outputable (HsTyVar name) where ppr sty (UserTyVar name) = ppr_hs_tyname sty name - ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppStr "::", ppr sty kind] + ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppPStr SLIT("::"), ppr sty kind] -- Here comes a rather gross hack. @@ -118,8 +118,8 @@ ppr_hs_tyname other_sty tv_name = ppr other_sty tv_name ppr_forall sty ctxt_prec [] [] ty = ppr_mono_ty sty ctxt_prec ty ppr_forall sty ctxt_prec tvs ctxt ty - = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs), - pprContext sty ctxt, ppStr "=>", + = ppSep [ppPStr SLIT("_forall_"), ppBracket (interppSP sty tvs), + pprContext sty ctxt, ppPStr SLIT("=>"), pprHsType sty ty] pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty @@ -156,7 +156,7 @@ ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2) p2 = ppr_mono_ty sty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) - (ppSep [p1, ppBeside (ppStr "-> ") p2]) + (ppSep [p1, ppBeside (ppPStr SLIT("-> ")) p2]) ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) = ppParens (ppInterleave ppComma (map (ppr sty) tys)) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index b695f4caf0..19e3d26d4c 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -46,6 +46,7 @@ module CmdLineOpts ( opt_D_verbose_core2core, opt_D_verbose_stg2stg, opt_DoCoreLinting, + opt_DoStgLinting, opt_DoSemiTagging, opt_DoEtaReduction, opt_DoTickyProfiling, @@ -58,6 +59,7 @@ module CmdLineOpts ( opt_Haskell_1_3, opt_HiMap, opt_HiSuffix, + opt_HiSuffixPrelude, opt_IgnoreIfacePragmas, opt_IgnoreStrictnessPragmas, opt_IrrefutableEverything, @@ -95,7 +97,9 @@ module CmdLineOpts ( opt_UnfoldingUseThreshold, opt_Verbose, - opt_WarnNameShadowing + opt_WarnNameShadowing, + opt_NoWarnIncompletePatterns + ) where IMPORT_1_3(Array(array, (//))) @@ -281,6 +285,7 @@ opt_D_source_stats = lookUp SLIT("-dsource-stats") opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl") opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg") opt_DoCoreLinting = lookUp SLIT("-dcore-lint") +opt_DoStgLinting = lookUp SLIT("-dstg-lint") opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction") @@ -293,6 +298,7 @@ opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files opt_HiSuffix = lookup_str "-hisuf=" +opt_HiSuffixPrelude = lookup_str "-hisuf-prelude=" opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") @@ -331,6 +337,7 @@ opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDIN opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_NoWarnIncompletePatterns = lookUp SLIT("-fno-warn-incomplete-patterns") -- opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" -- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" diff --git a/ghc/compiler/main/LoopHack.lhc b/ghc/compiler/main/LoopHack.lhc index 7f46936977..91d361bdb0 100644 --- a/ghc/compiler/main/LoopHack.lhc +++ b/ghc/compiler/main/LoopHack.lhc @@ -8,6 +8,57 @@ What we do here is simply to satisfy the unresolved references \begin{code} +#ifdef PROFILING +START_REGISTER_PRELUDE(_regUbiq); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regAbsCLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regNcgLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regDsLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regIdLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regPrelLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regSmplLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regTyLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regHsLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regSpecLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regTcMLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regTcLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regRnLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regCgLoop1); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regCgLoop2); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regHandleHack); +END_REGISTER_CCS() +#endif + +/* STGFUN(_regUbiq){} STGFUN(_regAbsCLoop){} STGFUN(_regNcgLoop){} @@ -23,5 +74,5 @@ STGFUN(_regTcLoop){} STGFUN(_regRnLoop){} STGFUN(_regCgLoop1){} STGFUN(_regCgLoop2){} - +*/ \end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 27bbe1e52d..9db06ac126 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -20,7 +20,7 @@ import RnMonad ( ExportEnv ) import MkIface -- several functions import TcModule ( typecheckModule ) -import Desugar ( deSugar, DsMatchContext, pprDsWarnings ) +import Desugar ( deSugar, DsMatchContext, pprDsWarnings, DsWarnFlavour {-TEMP!-} ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) import StgSyn ( collectFinalStgBinders ) @@ -56,12 +56,13 @@ import Unique ( Unique ) -- instances \end{code} \begin{code} -main - = hGetContents stdin >>= \ input_pgm -> - let - cmd_line_info = classifyOpts - in - doIt cmd_line_info input_pgm +main = + _scc_ "main" + hGetContents stdin >>= \ input_pgm -> + let + cmd_line_info = classifyOpts + in + doIt cmd_line_info input_pgm \end{code} \begin{code} @@ -82,13 +83,21 @@ doIt (core_cmds, stg_cmds) input_pgm (pp_show (ppSourceStats rdr_module)) >> -- UniqueSupplies for later use (these are the only lower case uniques) + _scc_ "spl-rn" mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer + _scc_ "spl-tc" mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker + _scc_ "spl-ds" mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer + _scc_ "spl-sm" mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier + _scc_ "spl-c2s" mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg + _scc_ "spl-st" mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes + _scc_ "spl-absc" mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener + _scc_ "spl-ncg" mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator -- ******* RENAMER @@ -207,6 +216,7 @@ doIt (core_cmds, stg_cmds) input_pgm let final_ids = collectFinalStgBinders stg_binds2 in + _scc_ "Interface" ifaceDecls if_handle rn_mod inst_info final_ids simplified >> endIface if_handle >> -- We are definitely done w/ interface-file stuff at this point: diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5bc488d7b6..15bb569644 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -19,6 +19,7 @@ import HsSyn import RdrHsSyn ( RdrName(..) ) import RnHsSyn ( SYN_IE(RenamedHsModule) ) import RnMonad +import RnEnv ( availName ) import TcInstUtil ( InstInfo(..) ) @@ -41,7 +42,7 @@ import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName, OccName, occNameString, nameOccName, nameString, isExported, pprNonSym, Name {-instance NamedThing-}, Provenance ) -import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) +import TyCon ( TyCon{-instance NamedThing-} ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) @@ -160,10 +161,11 @@ ifaceExports if_hdl avails -- Sort them into groups by module export_fm :: FiniteMap Module [AvailInfo] export_fm = foldr insert emptyFM avails - insert avail@(Avail name _) efm = addToFM_C (++) efm mod [avail] - where - (mod,_) = modAndOcc name + insert NotAvailable efm = efm + insert avail efm = addToFM_C (++) efm mod [avail] + where + (mod,_) = modAndOcc (availName avail) -- Print one module's worth of stuff do_one_module (mod_name, avails) @@ -251,16 +253,18 @@ ifaceId get_idinfo needed_ids is_rec id rhs = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs - = Just (ppCat [sig_pretty, prag_pretty, ppStr ";;"], new_needed_ids) + = Just (ppCat [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids) where - idinfo = get_idinfo id - inline_pragma = idWantsToBeINLINEd id + pp_double_semi = ppPStr SLIT(";;") + idinfo = get_idinfo id + inline_pragma = idWantsToBeINLINEd id ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id))) - sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty] + sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" _:_ "), ty_pretty] - prag_pretty | opt_OmitInterfacePragmas = ppNil - | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty] + prag_pretty + | opt_OmitInterfacePragmas = ppNil + | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi] ------------ Arity -------------- arity_pretty = ppArityInfo PprInterface (arityInfo idinfo) @@ -271,7 +275,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs strict_pretty = ppStrictnessInfo PprInterface strict_info ------------ Unfolding -------------- - unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs] + unfold_pretty | show_unfold = ppCat [ppPStr SLIT("_U_"), pprIfaceUnfolding rhs] | otherwise = ppNil show_unfold = not implicit_unfolding && -- Unnecessary @@ -373,22 +377,33 @@ ifaceBinds hdl needed_ids final_ids binds \subsection{Random small things} %* * %************************************************************************ - + +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C + \begin{code} -upp_avail NotAvailable = uppNil -upp_avail (Avail name ns) = uppBesides [upp_occname (getOccName name), upp_export ns] +upp_avail NotAvailable = uppNil +upp_avail (Avail name) = upp_occname (getOccName name) +upp_avail (AvailTC name []) = uppNil +upp_avail (AvailTC name ns) = uppBesides [upp_occname (getOccName name), bang, upp_export ns'] + where + bang | name `elem` ns = uppNil + | otherwise = uppChar '!' + ns' = filter (/= name) ns upp_export [] = uppNil -upp_export names = uppBesides [uppStr "(", +upp_export names = uppBesides [uppChar '(', uppIntersperse uppSP (map (upp_occname . getOccName) names), - uppStr ")"] + uppChar ')'] upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP, uppInt prec, uppSP, upp_occname occ, uppSemi] -upp_dir InfixR = uppStr "infixr" -upp_dir InfixL = uppStr "infixl" -upp_dir InfixN = uppStr "infix" +upp_dir InfixR = uppPStr SLIT("infixr") +upp_dir InfixL = uppPStr SLIT("infixl") +upp_dir InfixN = uppPStr SLIT("infix") ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name ppr_unqual_name name = upp_occname (getOccName name) @@ -428,9 +443,7 @@ by unique \begin{code} lt_avail :: AvailInfo -> AvailInfo -> Bool -NotAvailable `lt_avail` (Avail _ _) = True -(Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2 -any `lt_avail` NotAvailable = False +a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 lt_name :: Name -> Name -> Bool n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2 diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index d88986893c..3a87fecb4f 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -77,7 +77,7 @@ So, here we go: writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO () writeRealAsm handle absC us - = uppPutStr handle 80 (runNCG absC us) + = _scc_ "writeRealAsm" (uppPutStr handle 80 (runNCG absC us)) dumpRealAsm :: AbstractC -> UniqSupply -> String diff --git a/ghc/compiler/nativeGen/NCG.h b/ghc/compiler/nativeGen/NCG.h index 873ebebf87..d02415f0fd 100644 --- a/ghc/compiler/nativeGen/NCG.h +++ b/ghc/compiler/nativeGen/NCG.h @@ -14,7 +14,7 @@ you will screw up the layout where they are used in case expressions! #define FAST_REG_NO FAST_INT -#include "../../includes/platform.h" +#include "../../includes/config.h" #if 0 {-testing only-} diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 3d1665b598..d958af78d7 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -33,7 +33,7 @@ a_HASH x = GHCbase.A# x pACK_STR x = packCString x #else a_HASH x = A# x -pACK_STR x = _packCString x +pACK_STR x = mkFastCharString x --_packCString x #endif \end{code} @@ -428,15 +428,15 @@ pprInstr (LABEL clab) ] pprInstr (ASCII False{-no backslash conversion-} str) - = uppBesides [ uppStr "\t.asciz \"", uppStr str, uppChar '"' ] + = uppBesides [ uppPStr SLIT("\t.asciz \""), uppStr str, uppChar '"' ] pprInstr (ASCII True str) - = uppBeside (uppStr "\t.ascii \"") (asciify str 60) + = uppBeside (uppPStr SLIT("\t.ascii \"")) (asciify str 60) where asciify :: String -> Int -> Unpretty - asciify [] _ = uppStr ("\\0\"") - asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60) + asciify [] _ = uppPStr SLIT("\\0\"") + asciify s n | n <= 0 = uppBeside (uppPStr SLIT("\"\n\t.ascii \"")) (asciify s 60) asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1)) asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1)) asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1)) diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 4b4523f211..944b217612 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -22,8 +22,8 @@ import PreludeGlaST # define PACK_BYTES packCBytes #else # define ADDR _Addr -# define PACK_STR _packCString -# define PACK_BYTES _packCBytes +# define PACK_STR mkFastCharString +# define PACK_BYTES mkFastCharString2 #endif import RdrHsSyn ( RdrName(..) ) @@ -85,7 +85,7 @@ rdU_hstring :: ADDR -> UgnM U_hstring rdU_hstring x = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len -> ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes -> - returnUgn (PACK_BYTES len bytes) + returnUgn (PACK_BYTES bytes len) \end{code} \begin{code} diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index efac20b4a8..f7da732a6a 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -307,8 +307,18 @@ NL [\n\r] nested_comments =1; PUSH_STATE(Comment); } +<Code,GlaExt>"{-#"{WS}*"OPTIONS" { + /* these are by the driver! */ + nested_comments =1; + PUSH_STATE(Comment); + } +<Code,GlaExt>"{-#"{WS}*"SOURCE" { + /* these are used by `make depend' (temp) */ + nested_comments =1; + PUSH_STATE(Comment); + } <Code,GlaExt>"{-#"{WS}*[A-Z_]+ { - fprintf(stderr, "\"%s\", line %d: Warning: Unrecognised pragma '", + fprintf(stderr, "%s:%d: Warning: Unrecognised pragma '", input_filename, hsplineno); format_string(stderr, (unsigned char *) yytext, yyleng); fputs("'\n", stderr); @@ -381,6 +391,7 @@ NL [\n\r] <Code,GlaExt>"<-" { RETURN(LARROW); } <Code,GlaExt,UserPragma>"->" { RETURN(RARROW); } <Code,GlaExt>"-" { RETURN(MINUS); } +<Code,GlaExt>"+" { RETURN(PLUS); } <Code,GlaExt,UserPragma>"=>" { RETURN(DARROW); } <Code,GlaExt>"@" { RETURN(AT); } @@ -558,7 +569,7 @@ NL [\n\r] } if (length > 1) { - fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '", + fprintf(stderr, "%s:%d:%d: Unboxed character literal '", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) text, length); fputs("' too long\n", stderr); @@ -577,7 +588,7 @@ NL [\n\r] text = fetchtext(&length); if (length > 1) { - fprintf(stderr, "\"%s\", line %d, column %d: Character literal '", + fprintf(stderr, "%s:%d:%d: Character literal '", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) text, length); fputs("' too long\n", stderr); @@ -799,21 +810,21 @@ NL [\n\r] %} <INITIAL,Code,GlaExt,UserPragma>(.|\n) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + fprintf(stderr, "%s:%d:%d: Illegal character: `", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("'\n", stderr); hsperror(""); } <Char>(.|\n) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + fprintf(stderr, "%s:%d:%d: Illegal character: `", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("' in a character literal\n", stderr); hsperror(""); } <CharEsc>(.|\n) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\", + fprintf(stderr, "%s:%d:%d: Illegal character escape: `\\", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("'\n", stderr); @@ -822,7 +833,7 @@ NL [\n\r] <String>(.|\n) { if (nonstandardFlag) { addtext(yytext, yyleng); } else { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + fprintf(stderr, "%s:%d:%d: Illegal character: `", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("' in a string literal\n", stderr); @@ -831,13 +842,13 @@ NL [\n\r] } <StringEsc>(.|\n) { if (noGap) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\", + fprintf(stderr, "%s:%d:%d: Illegal string escape: `\\", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("'\n", stderr); hsperror(""); } else { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + fprintf(stderr, "%s:%d:%d: Illegal character: `", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("' in a string gap\n", stderr); diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 5212226d0a..77351a0740 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -47,6 +47,7 @@ static char *the_module_name; static maybe module_exports; extern list Lnil; +extern list reverse_list(); extern tree root; /* For FN, PREVPATT and SAMEFN macros */ @@ -170,7 +171,7 @@ BOOLEAN inpat; * * **********************************************************************/ -%token MINUS BANG +%token MINUS BANG PLUS %token AS HIDING QUALIFIED @@ -200,7 +201,7 @@ BOOLEAN inpat; SCC CASM CCALL CASM_GC CCALL_GC %left VARSYM CONSYM QVARSYM QCONSYM - MINUS BQUOTE BANG DARROW + MINUS BQUOTE BANG DARROW PLUS %left DCOLON @@ -223,7 +224,7 @@ BOOLEAN inpat; %type <ulist> caserest alts alt quals dorest stmts stmt - rbinds rpats list_exps + rbinds rbinds1 rpats rpats1 list_exps list_rest qvarsk qvars_list constrs constr1 fields types atypes batypes @@ -244,11 +245,11 @@ BOOLEAN inpat; %type <utree> exp oexp dexp kexp fexp aexp rbind texps expL oexpL kexpL expLno oexpLno dexpLno kexpLno vallhs funlhs qual gd leftexp - pat bpat apat apatc conpat rpat - patk bpatk apatck conpatk + pat cpat bpat apat apatc conpat rpat + patk bpatk apatck conpatk -%type <uid> MINUS DARROW AS LAZY +%type <uid> MINUS PLUS DARROW AS LAZY VARID CONID VARSYM CONSYM var con varop conop op vark varid varsym varsym_nominus @@ -270,10 +271,8 @@ BOOLEAN inpat; %type <uttype> simple ctype type atype btype gtyconvars - bbtype batype + bbtype batype bxtype bang_atype class tyvar -/* gtyconapp0 gtyconapp1 ntyconapp0 ntyconapp1 btyconapp */ -/* restrict_inst general_inst */ %type <uconstr> constr field @@ -734,24 +733,13 @@ constrs : constr { $$ = lsing($1); } | constrs VBAR constr { $$ = lapp($1,$3); } ; -constr : -/* This stuff looks really baroque. I've replaced it with simpler stuff. - SLPJ Jan 97 - - btyconapp { qid tyc; list tys; +constr : btype { qid tyc; list tys; splittyconapp($1, &tyc, &tys); $$ = mkconstrpre(tyc,tys,hsplineno); } - | btyconapp qconop bbtype { checknobangs($1); - $$ = mkconstrinf($1,$2,$3,hsplineno); } - | ntyconapp0 qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } - - | BANG atype qconop bbtype { $$ = mkconstrinf(mktbang($2),$3,$4,hsplineno); } - | OPAREN qconsym CPAREN { $$ = mkconstrpre($2,Lnil,hsplineno); } -*/ - - btype { qid tyc; list tys; + | bxtype { qid tyc; list tys; splittyconapp($1, &tyc, &tys); $$ = mkconstrpre(tyc,tys,hsplineno); } + /* We have to parse the constructor application as a *type*, else we get into terrible ambiguity problems. Consider the difference between @@ -764,24 +752,30 @@ constr : second. */ + | btype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } + | bang_atype qconop bbtype { $$ = mkconstrinf( $1, $2, $3, hsplineno ); } + + | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); } - | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } | gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); } /* 1 S/R conflict on OCURLY -> shift */ ; -/* -btyconapp: gtycon { $$ = mktname($1); } - | btyconapp batype { $$ = mktapp($1,$2); } +/* S !Int Bool */ +bxtype : btype bang_atype { $$ = mktapp($1, $2); } + | bxtype bbtype { $$ = mktapp($1, $2); } ; -*/ + bbtype : btype { $$ = $1; } - | BANG atype { $$ = mktbang($2); } + | bang_atype { $$ = $1; } ; batype : atype { $$ = $1; } - | BANG atype { $$ = mktbang($2); } + | bang_atype { $$ = $1; } + ; + +bang_atype : BANG atype { $$ = mktbang( $2 ) } ; batypes : { $$ = Lnil; } @@ -913,6 +907,8 @@ gdrhs : gd EQUAL exp { $$ = lsing(mkpgdexp($1,$3)); } maybe_where: WHERE ocurly decls ccurly { $$ = $3; } | WHERE vocurly decls vccurly { $$ = $3; } + /* A where containing no decls is OK */ + | WHERE SEMI { $$ = mknullbind(); } | /* empty */ { $$ = mknullbind(); } ; @@ -1036,7 +1032,6 @@ aexp : qvar { $$ = mkident($1); } | gcon { $$ = mkident($1); } | lit_constant { $$ = mklit($1); } | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */ - | qcon OCURLY CCURLY { $$ = mkrecord($1,Lnil); } | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */ | OBRACK list_exps CBRACK { $$ = mkllist($2); } | OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple) @@ -1045,7 +1040,7 @@ aexp : qvar { $$ = mkident($1); } $$ = mktuple(ldub($2, $4)); } /* only in expressions ... */ - | aexp OCURLY rbinds CCURLY { $$ = mkrupdate($1,$3); } + | aexp OCURLY rbinds1 CCURLY { $$ = mkrupdate($1,$3); } | OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); } | OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); } | OBRACK exp COMMA exp DOTDOT CBRACK { $$ = mkeenum($2,mkjust($4),mknothing()); } @@ -1073,8 +1068,12 @@ dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; } | vocurly stmts vccurly { checkdostmts($2); $$ = $2; } ; -rbinds : rbind { $$ = lsing($1); } - | rbinds COMMA rbind { $$ = lapp($1,$3); } +rbinds : /* empty */ { $$ = Lnil; } + | rbinds1 + ; + +rbinds1 : rbind { $$ = lsing($1); } + | rbinds1 COMMA rbind { $$ = lapp($1,$3); } ; rbind : qvar { $$ = mkrbind($1,mknothing()); } @@ -1093,10 +1092,22 @@ texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in t /* right recursion? WDP */ ; - list_exps : exp { $$ = lsing($1); } + | exp COMMA exp { $$ = mklcons( $1, lsing($3) ); } + | exp COMMA exp COMMA list_rest { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); } + ; + +/* Use left recusion for list_rest, because we sometimes get programs with + very long explicit lists. */ +list_rest : exp { $$ = lsing($1); } + | list_rest COMMA exp { $$ = mklcons( $3, $1 ); } + ; + +/* + exp { $$ = lsing($1); } | exp COMMA list_exps { $$ = mklcons($1, $3); } +*/ /* right recursion? (WDP) It has to be this way, though, otherwise you @@ -1108,7 +1119,6 @@ list_exps : (In fact, if you change the grammar and throw yacc/bison at it, it *will* do the wrong thing [WDP 94/06]) */ - ; letdecls: LET ocurly decls ccurly { $$ = $3 } | LET vocurly decls vccurly { $$ = $3 } @@ -1177,13 +1187,17 @@ leftexp : LARROW exp { $$ = $2; } * * **********************************************************************/ -pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); } +pat : qvar PLUS INTEGER { $$ = mkplusp($1, mkinteger($3)); } + | cpat + ; + +cpat : cpat qconop bpat { $$ = mkinfixap($2,$1,$3); } | bpat ; bpat : apatc | conpat - | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } + | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } | MINUS INTEGER { $$ = mknegate(mklit(mkinteger($2))); } | MINUS FLOAT { $$ = mknegate(mklit(mkfloatr($2))); } ; @@ -1230,8 +1244,12 @@ pats : pat COMMA pats { $$ = mklcons($1, $3); } /* right recursion? (WDP) */ ; -rpats : rpat { $$ = lsing($1); } - | rpats COMMA rpat { $$ = lapp($1,$3); } +rpats : /* empty */ { $$ = Lnil; } + | rpats1 + ; + +rpats1 : rpat { $$ = lsing($1); } + | rpats1 COMMA rpat { $$ = lapp($1,$3); } ; rpat : qvar { $$ = mkrbind($1,mknothing()); } @@ -1450,6 +1468,12 @@ varsym : varsym_nominus | MINUS { $$ = install_literal("-"); } ; +/* PLUS, BANG are valid varsyms */ +varsym_nominus : VARSYM + | PLUS { $$ = install_literal("+"); } + | BANG { $$ = install_literal("!"); } + ; + /* AS HIDING QUALIFIED are valid varids */ varid : VARID | AS { $$ = install_literal("as"); } @@ -1457,10 +1481,6 @@ varid : VARID | QUALIFIED { $$ = install_literal("qualified"); } ; -/* BANG are valid varsyms */ -varsym_nominus : VARSYM - | BANG { $$ = install_literal("!"); } - ; ccallid : VARID | CONID @@ -1577,7 +1597,7 @@ yyerror(s) /*NOTHING*/; } else { - fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ", + fprintf(stderr, "%s:%d:%d: %s on input: ", input_filename, hsplineno, hspcolno + 1, s); if (yyleng == 1 && *yytext == '\0') diff --git a/ghc/compiler/parser/id.c b/ghc/compiler/parser/id.c index 457dbd812a..173f38db98 100644 --- a/ghc/compiler/parser/id.c +++ b/ghc/compiler/parser/id.c @@ -54,7 +54,7 @@ installHstring(length, s) str->len = length; if (length == 0) { - str->bytes = NULL; + str->bytes = ""; } else { p = xmalloc(length); diff --git a/ghc/compiler/parser/main.c b/ghc/compiler/parser/main.c index 325c553940..eb1c58ecb4 100644 --- a/ghc/compiler/parser/main.c +++ b/ghc/compiler/parser/main.c @@ -24,6 +24,7 @@ main(int argc, char **argv) { Lnil = mklnil(); /* The null list -- used in lsing, etc. */ + argv++; argc--; process_args(argc,argv); hash_init(); diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c index 509145360a..a48b1198cb 100644 --- a/ghc/compiler/parser/syntax.c +++ b/ghc/compiler/parser/syntax.c @@ -13,6 +13,7 @@ #include "constants.h" #include "utils.h" #include "tree.h" +#include "list.h" #include "hsparser.tab.h" @@ -108,6 +109,9 @@ expORpat(int wanted, tree e) expORpat(wanted, glazyp(e)); break; + case plusp: + break; + case lit: switch (tliteral(glit(e))) { case integer: @@ -556,7 +560,7 @@ splittyconapp(app, tyc, tys) break; default: - hsperror("panic: splittyconap: bad tycon application (no tycon)"); + hsperror("bad left argument to constructor op"); } } @@ -701,3 +705,20 @@ checkprec(exp,qfn,right) #endif /* 0 */ + + +/* Reverse a list, in place */ + +list reverse_list( l ) + list l; +{ + list temp, acc = Lnil; + + while (tlist( l ) != lnil) { + temp = ltl( l ); + ltl( l ) = acc; + acc = l; + l = temp; + } + return( acc ); +} diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn index 86c5174c78..98d67c2f4d 100644 --- a/ghc/compiler/parser/tree.ugn +++ b/ghc/compiler/parser/tree.ugn @@ -72,8 +72,9 @@ type tree; as : < gasid : qid; gase : tree; >; lazyp : < glazyp : tree; >; + plusp : < gplusp : qid; + gplusi : literal; >; wildp : < >; - restr : < grestre : tree; grestrt : ttype; >; diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 7001a7bd01..98364f2573 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -292,6 +292,8 @@ knownKeyNames -- ClassOps , (fromInt_RDR, fromIntClassOpKey) , (fromInteger_RDR, fromIntegerClassOpKey) + , (ge_RDR, geClassOpKey) + , (minus_RDR, minusClassOpKey) , (enumFrom_RDR, enumFromClassOpKey) , (enumFromThen_RDR, enumFromThenClassOpKey) , (enumFromTo_RDR, enumFromToClassOpKey) @@ -299,8 +301,12 @@ knownKeyNames , (fromEnum_RDR, fromEnumClassOpKey) , (eq_RDR, eqClassOpKey) , (thenM_RDR, thenMClassOpKey) + , (returnM_RDR, returnMClassOpKey) , (zeroM_RDR, zeroClassOpKey) , (fromRational_RDR, fromRationalClassOpKey) + + -- Others + , (otherwiseId_RDR, otherwiseIdKey) ] \end{code} @@ -354,6 +360,7 @@ creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable")) fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt")) fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger")) +minus_RDR = varQual (pREL_BASE, SLIT("-")) fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) @@ -361,6 +368,7 @@ enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen")) enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) thenM_RDR = varQual (pREL_BASE, SLIT(">>=")) +returnM_RDR = varQual (pREL_BASE, SLIT("return")) zeroM_RDR = varQual (pREL_BASE, SLIT("zero")) fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational")) @@ -428,6 +436,8 @@ minusH_RDR = prelude_primop IntSubOp main_RDR = varQual (mAIN, SLIT("main")) mainPrimIO_RDR = varQual (gHC_MAIN, SLIT("mainPrimIO")) + +otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise")) \end{code} %************************************************************************ @@ -464,7 +474,7 @@ deriving_occ_info showParen_RDR, showSpace_RDR, showList___RDR]) , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR, lex_RDR, readParen_RDR, readList___RDR]) - , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR]) + , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR]) ] -- intTyCon: Practically any deriving needs Int, either for index calculations, -- or for taggery. diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi index ba1320a13e..9d5d407aba 100644 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ b/ghc/compiler/prelude/PrelLoop.lhi @@ -3,7 +3,8 @@ Breaks the PrelVal loop and the PrelInfo loop caused by primOpNameInfo. \begin{code} interface PrelLoop where -import PreludePS ( _PackedString ) +--import PreludePS ( _PackedString ) +import FastString ( FastSring ) import Class ( GenClass ) import CoreUnfold ( mkMagicUnfolding, Unfolding ) diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 8d9a5ad6e6..321b83c4da 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -4,15 +4,53 @@ \section[PrelMods]{Definitions of prelude modules} The strings identify built-in prelude modules. They are -defined here so as to avod +defined here so as to avod + +[oh dear, look like the recursive module monster caught up and + gobbled whoever was writing the above :-) -- SOF ] + \begin{code} #include "HsVersions.h" -module PrelMods where +module PrelMods + ( + isPreludeModule, -- :: Module -> Bool + + gHC__, pRELUDE, pREL_BASE, + pREL_READ , pREL_NUM, pREL_LIST, + pREL_TUP , pACKED_STRING, cONC_BASE, + iO_BASE , mONAD, rATIO, iX, + sT_BASE , aRR_BASE, fOREIGN, mAIN, + gHC_MAIN , gHC_ERR + ) where CHK_Ubiq() -- debugging consistency check +import UniqSet ( UniqSet(..), mkUniqSet, elementOfUniqSet ) + \end{code} +Predicate used by RnIface to decide whether or not to +append a special suffix for prelude modules: + +\begin{code} +isPreludeModule :: Module -> Bool +isPreludeModule mod = mod `elementOfUniqSet` preludeNames + +preludeNames :: UniqSet FAST_STRING +preludeNames = + mkUniqSet + [ gHC__ + , pRELUDE , pREL_BASE + , pREL_READ , pREL_NUM + , pREL_LIST , pREL_TUP + , pACKED_STRING , cONC_BASE + , iO_BASE , mONAD + , rATIO , iX + , sT_BASE , aRR_BASE + , fOREIGN , mAIN + , gHC_MAIN , gHC_ERR + ] +\end{code} \begin{code} gHC__ = SLIT("GHC") -- Primitive types and values @@ -36,4 +74,7 @@ fOREIGN = SLIT("Foreign") mAIN = SLIT("Main") gHC_MAIN = SLIT("GHCmain") gHC_ERR = SLIT("GHCerr") + + + \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 741911b592..046e6fa79d 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -571,7 +571,7 @@ realWorldPrimId \end{code} \begin{code} -voidId = pc_bottoming_Id voidIdKey gHC__ SLIT("void") voidTy +voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 7af6822120..bd24ebe37d 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1400,9 +1400,13 @@ primOpHeapReq DoubleDecodeOp = FixedHeapRequired (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) (intOff mIN_MP_INT_SIZE))) --- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_) --- or if it returns a ForeignObj. +{- + ccall may allocate heap if it is explicitly allowed to (_ccall_gc_) + or if it returns a ForeignObj. + Hmm..the allocation for makeForeignObj# is known (and fixed), so + why dod we need to be so indeterminate about it? --SOF +-} primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 94ab0c50f2..387f70d8a9 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -15,8 +15,8 @@ module PrimRep ( separateByPtrFollowness, isFollowableRep, isFloatingRep, getPrimRepSize, retPrimRepSize, - showPrimRep, - guessPrimRep + showPrimRep, ppPrimRep, + guessPrimRep, decodePrimRep ) where IMP_Ubiq() @@ -85,8 +85,12 @@ isFollowableRep :: PrimRep -> Bool isFollowableRep PtrRep = True isFollowableRep ArrayRep = True isFollowableRep ByteArrayRep = True --- why is a MallocPtr followable? 4/96 SOF --- isFollowableRep ForeignObjRep = True +-- why is a ForeignObj followable? 4/96 SOF +-- +-- A: they're followable because these objects +-- should be lugged around by the storage manager +-- (==> we need to generate code that identify them as such) -- 3/97 SOF +isFollowableRep ForeignObjRep = True isFollowableRep StablePtrRep = False -- StablePtrs aren't followable because they are just indices into a @@ -145,7 +149,32 @@ instance Outputable PrimRep where ppr sty kind = ppStr (showPrimRep kind) showPrimRep :: PrimRep -> String +-- dumping PrimRep tag for unfoldings +ppPrimRep :: PrimRep -> Pretty + guessPrimRep :: String -> PrimRep -- a horrible "inverse" function +decodePrimRep :: Char -> PrimRep -- of equal nature + +ppPrimRep k = + ppChar + (case k of + PtrRep -> 'P' + CodePtrRep -> 'p' + DataPtrRep -> 'd' + CostCentreRep -> 'c' -- Pointer to a cost centre + RetRep -> 'R' + CharRep -> 'C' + IntRep -> 'I' + WordRep -> 'W' + AddrRep -> 'A' + FloatRep -> 'F' + DoubleRep -> 'D' + ArrayRep -> 'a' + ByteArrayRep -> 'b' + StablePtrRep -> 'S' + ForeignObjRep -> 'f' + VoidRep -> 'V' + _ -> panic "ppPrimRep") showPrimRep PtrRep = "P_" -- short for StgPtr @@ -169,6 +198,26 @@ showPrimRep StablePtrRep = "StgStablePtr" showPrimRep ForeignObjRep = "StgPtr" -- see comment below showPrimRep VoidRep = "!!VOID_KIND!!" +decodePrimRep ch = + case ch of + 'P' -> PtrRep + 'p' -> CodePtrRep + 'd' -> DataPtrRep + 'c' -> CostCentreRep + 'R' -> RetRep + 'C' -> CharRep + 'I' -> IntRep + 'W' -> WordRep + 'A' -> AddrRep + 'F' -> FloatRep + 'D' -> DoubleRep + 'a' -> ArrayRep + 'b' -> ByteArrayRep + 'S' -> StablePtrRep + 'f' -> ForeignObjRep + 'V' -> VoidRep + _ -> panic "decodePrimRep" + guessPrimRep "D_" = DataPtrRep guessPrimRep "StgRetAddr" = RetRep guessPrimRep "StgChar" = CharRep diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index bb2ede0448..2f0b008372 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -30,7 +30,7 @@ module CostCentre ( IMP_Ubiq(){-uitous-} -import Id ( externallyVisibleId, GenId, SYN_IE(Id) ) +import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) ) import CStrings ( identToC, stringToC ) import Name ( OccName, getOccString, moduleString ) import Pretty ( ppShow, prettyToUn ) @@ -39,7 +39,6 @@ import UniqSet import Unpretty import Util -showId = panic "Whoops" pprIdInUnfolding = panic "Whoops" \end{code} @@ -371,7 +370,6 @@ uppCostCentre sty print_as_string cc friendly_sty = friendly_style sty ---------------- - do_cc OverheadCC = "OVERHEAD" do_cc DontCareCC = "DONT_CARE" do_cc (AllCafsCC m _) = if print_as_string then "CAFs_in_..." @@ -432,14 +430,19 @@ even if we won't ultimately do a \tr{SET_CCC} from it. upp_cc_uf (PreludeDictsCC d) = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] upp_cc_uf (AllDictsCC m g d) - = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d] + = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), + uppChar '"',uppPStr m,uppChar '"', + uppChar '"',uppPStr g,uppChar '"', + upp_dupd d] upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) = ASSERT(sccAbleCostCentre cc) - uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), + uppCat [pp_kind cc_kind, + uppChar '"', uppPStr m, uppChar '"', + uppChar '"', uppPStr g, uppChar '"', upp_dupd is_dupd, pp_caf is_caf] where - pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name))) + pp_kind (UserCC name) = uppBesides [uppPStr SLIT("_USER_CC_ "), uppChar '"', uppPStr name, uppChar '"'] pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id) pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id) @@ -455,7 +458,7 @@ upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other)) #endif upp_dupd AnOriginalCC = uppPStr SLIT("_N_") -upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_") +upp_dupd ADupdCC = uppPStr SLIT("_D_") \end{code} \begin{code} @@ -467,7 +470,7 @@ uppCostCentreDecl sty is_local cc #endif = if is_local then uppBesides [ - uppStr "CC_DECLARE(", + uppPStr SLIT("CC_DECLARE"),uppChar '(', upp_ident, uppComma, uppCostCentre sty True {-as String!-} cc, uppComma, pp_str mod_name, uppComma, @@ -476,12 +479,12 @@ uppCostCentreDecl sty is_local cc if externally_visible then uppNil else uppPStr SLIT("static"), uppStr ");"] else - uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ] + uppBesides [ uppPStr SLIT("CC_EXTERN"),uppChar '(', upp_ident, uppStr ");" ] where upp_ident = uppCostCentre sty False{-as identifier!-} cc - pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"') - pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'') + pp_str s = uppBesides [uppChar '"',uppPStr s, uppChar '"' ] + pp_char c = uppBesides [uppChar '\'', uppPStr c, uppChar '\''] (mod_name, grp_name, is_subsumed, externally_visible) = case cc of diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index ec761e4659..32f20e9e1f 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -10,27 +10,39 @@ module Lex ( isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - mkTupNameStr, + mkTupNameStr, ifaceParseErr, -- Monad for parser - IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError + IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError, + StringBuffer ) where IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper)) +IMPORT_DELOOPER(Ubiq) +IMPORT_DELOOPER(IdLoop) -- get the CostCentre type&constructors from here import CmdLineOpts ( opt_IgnoreIfacePragmas ) -import Demand ( Demand {- instance Read -} ) -import FiniteMap ( FiniteMap, listToFM, lookupFM ) +import Demand ( Demand(..) {- instance Read -} ) +import UniqFM ( UniqFM, listToUFM, lookupUFM) +--import FiniteMap ( FiniteMap, listToFM, lookupFM ) import Maybes ( Maybe(..), MaybeErr(..) ) import Pretty import CharSeq ( CSeq ) + + + import ErrUtils ( Error(..) ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..) ) import Util ( nOfThem, panic ) +import FastString +import StringBuffer + +import PreludeGlaST + \end{code} %************************************************************************ @@ -86,8 +98,10 @@ isLexVarSym cs ------------- isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# +--0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c +isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# +--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c \end{code} @@ -114,6 +128,28 @@ mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") %* * %************************************************************************ +The token data type, fairly un-interesting except from two constructors, +@ITidinfo@ and @ITtype@, which are used to lazily lex id info (arity, +strictness, unfolding etc) and types for id decls. + +The Idea/Observation here is that the renamer needs to scan through +all of an interface file before it can continue. But only a fraction +of the information contained in the file turns out to be useful, so +delaying as much as possible of the scanning and parsing of an +interface file Makes Sense (Heap profiles of the compiler +show at a reduction in heap usage by at least a factor of two, +post-renamer). + +Hence, the interface file lexer spots when value declarations are +being scanned and return the @ITidinfo@ and @ITtype@ constructors +for the type and any other id info for that binding (unfolding, strictness +etc). These constructors are applied to the result of lexing these sub-chunks. + +The lexing of the type and id info is all done lazily, of course, so +the scanning (and subsequent parsing) will be done *only* on the ids the +renamer finds out that it is interested in. The rest will just be junked. +Laziness, you know it makes sense :-) + \begin{code} data IfaceToken = ITinterface -- keywords @@ -144,8 +180,6 @@ data IfaceToken | ITdotdot | ITequal | ITocurly - | ITdccurly - | ITdocurly | ITobrack | IToparen | ITrarrow @@ -162,17 +196,25 @@ data IfaceToken | ITqvarsym (FAST_STRING,FAST_STRING) | ITqconsym (FAST_STRING,FAST_STRING) + | ITidinfo [IfaceToken] -- lazily return the stream of tokens for + -- the info attached to an id. + | ITtysig [IfaceToken] -- lazily return the stream of tokens for + -- the info attached to an id. -- Stuff for reading unfoldings | ITarity | ITstrict | ITunfold | ITdemand [Demand] | ITbottom | ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof | ITcoerce_in | ITcoerce_out | ITatsign | ITccall (Bool,Bool) -- (is_casm, may_gc) - + | ITscc CostCentre | ITchar Char | ITstring FAST_STRING | ITinteger Integer | ITdouble Double | ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit + | ITunknown String -- Used when the lexer can't make sense of it deriving Text -- debugging + +instance Text CostCentre -- cheat! + \end{code} %************************************************************************ @@ -182,144 +224,487 @@ data IfaceToken %************************************************************************ \begin{code} -lexIface :: String -> [IfaceToken] - -lexIface input - = _scc_ "Lexer" - case input of - [] -> [] - - -- whitespace and comments - ' ' : cs -> lexIface cs - '\t' : cs -> lexIface cs - '\n' : cs -> lexIface cs - '-' : '-' : cs -> lex_comment cs +lexIface :: StringBuffer -> [IfaceToken] +lexIface buf = + _scc_ "Lexer" +-- if bufferExhausted buf then +-- [] +-- else +-- _trace ("Lexer: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + -- whitespace and comments, ignore. + ' '# -> lexIface (stepOn buf) + '\t'# -> lexIface (stepOn buf) + '\n'# -> lexIface (stepOn buf) + +-- Numbers and comments + '-'# -> + case lookAhead# buf 1# of + '-'# -> lex_comment (stepOnBy# buf 2#) + c -> + if isDigit (C# c) + then lex_num (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf)) + else lex_id buf -- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake? -- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs - '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs - '{' : cs -> ITocurly : lexIface cs - '}' : cs -> ITccurly : lexIface cs - '(' : ',' : cs -> lex_tuple Nothing cs - '(' : ')' : cs -> ITconid SLIT("()") : lexIface cs - '(' : cs -> IToparen : lexIface cs - ')' : cs -> ITcparen : lexIface cs - '[' : ']' : cs -> ITconid SLIT("[]") : lexIface cs - '[' : cs -> ITobrack : lexIface cs - ']' : cs -> ITcbrack : lexIface cs - ',' : cs -> ITcomma : lexIface cs - ':' : ':' : cs -> ITdcolon : lexIface cs - ';' : cs -> ITsemi : lexIface cs - '\"' : cs -> case reads input of - [(str, rest)] -> ITstring (_PK_ (str::String)) : lexIface rest - '\'' : cs -> case reads input of - [(ch, rest)] -> ITchar ch : lexIface rest + '('# -> + case prefixMatch (stepOn buf) "..)" of + Just buf' -> ITdotdot : lexIface (stepOverLexeme buf') + Nothing -> + case lookAhead# buf 1# of + ','# -> lex_tuple Nothing (stepOnBy# buf 2#) + ')'# -> ITconid SLIT("()") : lexIface (stepOnBy# buf 2#) + _ -> IToparen : lexIface (stepOn buf) + + '{'# -> ITocurly : lexIface (stepOn buf) + '}'# -> ITccurly : lexIface (stepOn buf) + ')'# -> ITcparen : lexIface (stepOn buf) + '['# -> + case lookAhead# buf 1# of + ']'# -> ITconid SLIT("[]") : lexIface (stepOnBy# buf 2#) + _ -> ITobrack : lexIface (stepOn buf) + ']'# -> ITcbrack : lexIface (stepOn buf) + ','# -> ITcomma : lexIface (stepOn buf) + ':'# -> case lookAhead# buf 1# of + ':'# -> ITdcolon : lexIface (stepOnBy# buf 2#) + _ -> lex_id (incLexeme buf) + ';'# -> ITsemi : lexIface (stepOn buf) + '\"'# -> case untilEndOfString# (stepOn buf) of + buf' -> + -- the string literal does *not* include the dquotes + case lexemeToFastString buf' of + v -> ITstring v : lexIface (stepOn (stepOverLexeme buf')) + + '\''# -> -- + -- untilEndOfChar# extends the current lexeme until + -- it hits a non-escaped single quote. The lexeme of the + -- StringBuffer returned does *not* include the closing quote, + -- hence we augment the lexeme and make sure to add the + -- starting quote, before `read'ing the string. + -- + case untilEndOfChar# (stepOn buf) of + buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of + [ (ch, rest)] -> ITchar ch : lexIface (stepOverLexeme (incLexeme buf')) -- ``thingy'' form for casm - '`' : '`' : cs -> lex_cstring "" cs - + '`'# -> + case lookAhead# buf 1# of + '`'# -> lex_cstring (stepOnBy# buf 2#) -- remove the `` and go. + _ -> lex_id (incLexeme buf) -- add ` to lexeme and assume + -- scanning an id of some sort. -- Keywords - '_' : 'S' : '_' : cs -> ITstrict : lex_demand cs - '_' : cs -> lex_keyword cs - --- Numbers - '-' : c : cs | isDigit c -> lex_num "-" (c:cs) - c : cs | isDigit c -> lex_num "" (c:cs) - - other -> lex_id input - where - lex_comment str - = case (span ((/=) '\n') str) of { (junk, rest) -> - lexIface rest } - - ------------------ - lex_demand (c:cs) | isSpace c = lex_demand cs - | otherwise = case readList (c:cs) of - ((demand,rest) : _) -> ITdemand demand : lexIface rest - - ----------- - lex_num minus str - = case (span isDigit str) of { (num, rest) -> - case rest of - '.' : str2 -> case (span isDigit str2) of { (num2,rest2) -> - ITdouble (read (minus ++ num ++ ('.':num2))) : lexIface rest2 - } - - other -> ITinteger (read (minus ++ num)) : lexIface rest - } - - ------------ - lex_keyword str - = case (span is_kwd_mod_char str) of { (kw, rest) -> - case (lookupFM ifaceKeywordsFM kw) of - Nothing -> panic ("lex_keyword:"++str) - - Just xx | startDiscard xx && - opt_IgnoreIfacePragmas -> lexIface (doDiscard rest) - | otherwise -> xx : lexIface rest - } - - is_kwd_mod_char c = isAlphanum c || c `elem` "_@/\\" - - ----------- - lex_cstring so_far ('\'' : '\'' : cs) = ITstring (_PK_ (reverse (so_far::String))) : lexIface cs - lex_cstring so_far (c : cs) = lex_cstring (c:so_far) cs + '_'# -> + case lookAhead# buf 1# of + 'S'# -> case lookAhead# buf 2# of + '_'# -> ITstrict : + lex_demand (stepOnUntil (not . isSpace) + (stepOnBy# buf 3#)) -- past _S_ + 's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of + Just buf' -> lex_scc (stepOnUntil (not . isSpace) + (stepOverLexeme buf')) + Nothing -> lex_keyword (stepOnBy# buf 1#) -- drop the '_' and assume + -- it is a keyword. + _ -> lex_keyword (stepOn buf) + + '\NUL'# -> + if bufferExhausted (stepOn buf) then + [] + else + lex_id buf + c -> + if isDigit (C# c) then + lex_num (id) (ord# c -# ord# '0'#) (incLexeme buf) + else + lex_id buf +-- where +lex_comment buf = +-- _trace ("comment: "++[C# (currentChar# buf)]) $ + case untilChar# buf '\n'# of {buf' -> lexIface (stepOverLexeme buf')} + +------------------ +lex_demand buf = +-- _trace ("demand: "++[C# (currentChar# buf)]) $ + case read_em [] buf of { (ls,buf') -> ITdemand ls : lexIface (stepOverLexeme buf')} + where + -- code snatched from Demand.lhs + read_em acc buf = +-- _trace ("read_em: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + 'L'# -> read_em (WwLazy False : acc) (stepOn buf) + 'A'# -> read_em (WwLazy True : acc) (stepOn buf) + 'S'# -> read_em (WwStrict : acc) (stepOn buf) + 'P'# -> read_em (WwPrim : acc) (stepOn buf) + 'E'# -> read_em (WwEnum : acc) (stepOn buf) + ')'# -> (reverse acc, stepOn buf) + 'U'# -> do_unpack True acc (stepOnBy# buf 2#) + 'u'# -> do_unpack False acc (stepOnBy# buf 2#) + _ -> (reverse acc, buf) + + do_unpack wrapper_unpacks acc buf + = case read_em [] buf of + (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest + +------------------ +lex_scc buf = +-- _trace ("scc: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + '"'# -> + -- YUCK^2 + case prefixMatch (stepOn buf) "NO_CC\"" of + Just buf' -> ITscc noCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CURRENT_CC\"" of + Just buf' -> ITscc useCurrentCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "OVERHEAD\"" of + Just buf' -> ITscc overheadCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "DONT_CARE\"" of + Just buf' -> ITscc dontCareCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "SUBSUMED\"" of + Just buf' -> ITscc subsumedCosts : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CAFs_in_...\"" of + Just buf' -> ITscc preludeCafsCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CC_CAFs_in_..." of + Just buf' -> + case untilChar# (stepOverLexeme buf') '\"'# of + buf'' -> ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_): + lexIface (stepOverLexeme buf'') + Nothing -> + case prefixMatch (stepOn buf) "DICTs_in_...\"" of + Just buf' -> ITscc (preludeDictsCostCentre True) : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CC_DICTs_in_..." of + Just buf' -> + case untilChar# (stepOverLexeme buf') '\"'# of + buf'' -> ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True): + lexIface (stepOverLexeme buf'') + Nothing -> + case prefixMatch (stepOn buf) "CAF:" of + Just buf' -> + case untilChar# (stepOverLexeme buf') '\"'# of + buf'' -> ITscc (cafifyCC (mkUserCC (lexemeToFastString buf'') _NIL_ _NIL_)): + lexIface (stepOverLexeme buf'') + Nothing -> + case untilChar# (stepOn buf) '\"'# of + buf' -> ITscc (mkUserCC (lexemeToFastString buf') _NIL_ _NIL_): + lexIface (stepOverLexeme buf') + c -> ITunknown [C# c] : lexIface (stepOn buf) + + +----------- +lex_num :: (Int -> Int) -> Int# -> StringBuffer -> [IfaceToken] +lex_num minus acc# buf = +-- _trace ("lex_num: "++[C# (currentChar# buf)]) $ + case scanNumLit (I# acc#) buf of + (acc',buf') -> + case currentChar# buf' of + '.'# -> + -- this case is not optimised at all, as the + -- presence of floating point numbers in interface + -- files is not that common. (ToDo) + case expandWhile (isDigit) (incLexeme buf') of + buf'' -> -- points to first non digit char + case reads (lexemeToString buf'') of + [(v,_)] -> ITdouble v : lexIface (stepOverLexeme buf'') + _ -> ITinteger (fromInt (minus acc')) : lexIface (stepOverLexeme buf') + +-- case reads (lexemeToString buf') of +-- [(i,_)] -> ITinteger i : lexIface (stepOverLexeme buf') + +------------ +lex_keyword buf = +-- _trace ("lex_keyword: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + ':'# -> case lookAhead# buf 1# of + '_'# -> -- a binding, type (and other id-info) follows, + -- to make the parser ever so slightly, we push + -- + lex_decl (stepOnBy# buf 2#) + v# -> ITunknown (['_',':',C# v#]) : lexIface (stepOnBy# buf 2#) + _ -> + case expandWhile (is_kwd_char) buf of + buf' -> + let kw = lexemeToFastString buf' in +-- _trace ("kw: "++lexemeToString buf') $ + case lookupUFM ifaceKeywordsFM kw of + Nothing -> ITunknown (_UNPK_ kw) : -- (minor) sigh + lexIface (stepOverLexeme buf') + Just xx -> xx : lexIface (stepOverLexeme buf') + +lex_decl buf = + case expandUntilMatch buf ";;" of + buf' -> +-- _trace (show (lexemeToString buf')) $ + case currentChar# buf' of + '\n'# -> -- newline, no id info. + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : + lexIface (stepOverLexeme buf') + '\r'# -> -- just to be sure for those Win* boxes.. + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : + lexIface (stepOverLexeme buf') + '\NUL'# -> + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : + lexIface (stepOverLexeme buf') + c -> -- run all over the id info + case expandUntilMatch (stepOverLexeme buf') ";;" of + buf'' -> + --_trace ((C# c):show (lexemeToString (decLexeme buf'))) $ + --_trace (show (lexemeToString (decLexeme buf''))) $ + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))): + let ls = lexIface (stepOverLexeme buf'') in + if opt_IgnoreIfacePragmas then + ls + else + let is = lexIface (lexemeToBuffer (decLexeme buf'')) in + --_trace (show is) $ + ITidinfo is : ls + +-- ToDo: hammer! +is_kwd_char c@(C# c#) = + isAlphanum c || -- OLD: c `elem` "_@/\\" + (case c# of + '_'# -> True + '@'# -> True + '/'# -> True + '\\'# -> True + _ -> False) + + + +----------- +lex_cstring buf = +-- _trace ("lex_cstring: "++[C# (currentChar# buf)]) $ + case expandUntilMatch buf "\'\'" of + buf' -> ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))) : + lexIface (stepOverLexeme buf') - - ----------- - lex_tuple module_dot orig_cs = go 2 orig_cs - where - go n (',':cs) = go (n+1) cs - go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs - go n other = panic ("lex_tuple" ++ orig_cs) - - -- Similarly ' itself is ok inside an identifier, but not at the start - is_id_char c = isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic - - lex_id cs = go [] cs - where - go xs (f :cs) | is_kwd_mod_char f = go (f : xs) cs - go xs ('.':cs) | not (null xs) = lex_id2 (Just (_PK_ (reverse xs))) [] cs - go xs cs = lex_id2 Nothing xs cs - - -- Dealt with the Module.part - lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs - lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs - lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs - lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs - lex_id2 module_dot xs cs = lex_id3 module_dot xs cs - - -- Dealt with [], (), : special cases - lex_id3 module_dot xs (f:cs) | is_id_char f = lex_id3 module_dot (f : xs) cs - - lex_id3 Nothing xs rest = case lookupFM haskellKeywordsFM rxs of - Just kwd_token -> kwd_token : lexIface rest - other -> (mk_var_token rxs) : lexIface rest - where - rxs = reverse xs - - lex_id3 (Just m) xs rest = end_lex_id (Just m) (mk_var_token (reverse xs)) rest - +----------- +lex_tuple module_dot buf = +-- _trace ("lex_tuple: "++[C# (currentChar# buf)]) $ + go 2 buf + where + go n buf = + case currentChar# buf of + ','# -> go (n+1) (stepOn buf) + ')'# -> end_lex_id module_dot (ITconid (mkTupNameStr n)) (stepOn buf) + _ -> ITunknown ("tuple " ++ show n) : lexIface buf + +-- Similarly ' itself is ok inside an identifier, but not at the start + +id_arr :: _ByteArray Int +id_arr = + unsafePerformPrimIO ( + newCharArray (0,255) `thenPrimIO` \ barr -> + let + loop 256# = returnPrimIO () + loop i# = + if isAlphanum (C# (chr# i#)) || is_sym (chr# i#) then + writeCharArray barr (I# i#) '\1' `seqPrimIO` + loop (i# +# 1#) + else + writeCharArray barr (I# i#) '\0' `seqPrimIO` + loop (i# +# 1#) + in + loop 0# `seqPrimIO` + unsafeFreezeByteArray barr) + +is_id_char (C# c#) = + let + _ByteArray _ arr# = id_arr + in + case ord# (indexCharArray# arr# (ord# c#)) of + 0# -> False + 1# -> True + +--is_id_char c@(C# c#) = isAlphanum c || is_sym c# + +is_sym c#= + case c# of { + ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True; + '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True; + '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True; + '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True; + '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True; + '-'# -> True; '~'# -> True; _ -> False } + +--isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic + + +mod_arr :: _ByteArray Int +mod_arr = + unsafePerformPrimIO ( + newCharArray (0,255) `thenPrimIO` \ barr -> + let + loop 256# = returnPrimIO () + loop i# = + if isAlphanum (C# (chr# i#)) || i# ==# (ord# '_'#) || i# ==# (ord# '\''#) then + writeCharArray barr (I# i#) '\1' `seqPrimIO` + loop (i# +# 1#) + else + writeCharArray barr (I# i#) '\0' `seqPrimIO` + loop (i# +# 1#) + in + loop 0# `seqPrimIO` + unsafeFreezeByteArray barr) + + +is_mod_char (C# c#) = + let + _ByteArray _ arr# = mod_arr + in + case ord# (indexCharArray# arr# (ord# c#)) of + 0# -> False + 1# -> True + +--isAlphanum c || c == '_' || c== '\'' --`elem` "_'" + +{- +lex_id cs = + case _scc_ "lex_id.span" my_span' (is_mod_char) cs of + (xs, len, cs') -> + case cs' of + [] -> case xs of + [] -> lex_id2 Nothing cs + _ -> lex_id3 Nothing len xs cs + + '.':cs'' -> + case xs of + [] -> lex_id2 Nothing cs + _ -> + let + pk_str = _PK_ (xs::String) + len = lengthPS pk_str + in + if len==len+1 then + error "Well, I never!" + else + lex_id2 (Just pk_str) cs'' + _ -> case xs of + [] -> lex_id2 Nothing cs + _ -> lex_id3 Nothing len xs cs' + +-} + +lex_id buf = +-- _trace ("lex_id: "++[C# (currentChar# buf)]) $ + case expandWhile (is_mod_char) buf of + buf' -> + case currentChar# buf' of + '.'# -> + if not (emptyLexeme buf') then +-- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $ + case lexemeToFastString buf' of + l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#)) + (stepOn (stepOverLexeme buf')) + else + lex_id2 Nothing buf' + _ -> lex_id2 Nothing buf' + +-- Dealt with the Module.part +lex_id2 module_dot buf = +-- _trace ("lex_id2: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + '['# -> + case lookAhead# buf 1# of + ']'# -> end_lex_id module_dot (ITconid SLIT("[]")) (stepOnBy# buf 2#) + _ -> lex_id3 module_dot buf + '('# -> + case lookAhead# buf 1# of + ')'# -> end_lex_id module_dot (ITconid SLIT("()")) (stepOnBy# buf 2#) + ','# -> lex_tuple module_dot (stepOnBy# buf 2#) + _ -> lex_id3 module_dot buf + ':'# -> lex_id3 module_dot (incLexeme buf) + _ -> lex_id3 module_dot buf + + + +-- Dealt with [], (), : special cases + +lex_id3 module_dot buf = +-- _trace ("lex_id3: "++[C# (currentChar# buf)]) $ + case expandWhile (is_id_char) buf of + buf' -> + case module_dot of + Just _ -> + end_lex_id module_dot (mk_var_token lexeme) (stepOverLexeme buf') + Nothing -> + case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of + Just kwd_token -> kwd_token : lexIface new_buf + Nothing -> mk_var_token lexeme : lexIface new_buf + where + lexeme = lexemeToFastString buf' + new_buf = stepOverLexeme buf' + + +{- OLD: +lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs +lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs +lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs +lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs +lex_id2 module_dot xs cs = lex_id3 module_dot xs cs +-} + + +-- Dealt with [], (), : special cases + +{- +lex_id3 module_dot len_xs xs cs = + case my_span' (is_id_char) cs of + (xs1,len_xs1,rest) -> + case module_dot of + Just m -> end_lex_id (Just m) (mk_var_token rxs) rest --OLD:_PK_ (reverse xs))) rest + Nothing -> + case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM rxs of + Just kwd_token -> kwd_token : lexIface rest + other -> token : lexIface cs end_lex_id Nothing (mk_var_token rxs) rest + where + rxs = packNChars (len_xs+len_xs1) (xs++xs1) -- OLD: _PK_ (reverse xs) +-} +mk_var_token pk_str = + let + f = _HEAD_ pk_str + in + -- + -- These tests assume a non- ISO-8859-1 impl of isUpper&isLower, + -- remove the second half of disjunction when using a 1.3 prelude. + -- + if isUpper f then ITconid pk_str + else if isLower f then ITvarid pk_str + else if f == ':' then ITconsym pk_str + else if isLowerISO f then ITvarid pk_str + else if isUpperISO f then ITconid pk_str + else ITvarsym pk_str + +{- mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n | f == ':' = ITconsym n | isAlpha f = ITvarid n | otherwise = ITvarsym n where n = _PK_ xs +-} - end_lex_id (Just m) (ITconid n) cs = ITqconid (m,n) : lexIface cs - end_lex_id (Just m) (ITvarid n) cs = ITqvarid (m,n) : lexIface cs - end_lex_id (Just m) (ITconsym n) cs = ITqconsym (m,n): lexIface cs - end_lex_id (Just m) (ITvarsym n) cs = ITqvarsym (m,n): lexIface cs - end_lex_id (Just m) ITbang cs = ITqvarsym (m,SLIT("!")) : lexIface cs - end_lex_id (Just m) token cs = panic ("end_lex_id:" ++ show token) - end_lex_id Nothing token cs = token : lexIface cs - - ------------ - ifaceKeywordsFM :: FiniteMap String IfaceToken - ifaceKeywordsFM = listToFM [ - ("/\\_", ITbiglam) +end_lex_id Nothing token buf = token : lexIface buf +end_lex_id (Just m) token buf = + case token of + ITconid n -> ITqconid (m,n) : lexIface buf + ITvarid n -> ITqvarid (m,n) : lexIface buf + ITconsym n -> ITqconsym (m,n) : lexIface buf + ITvarsym n -> ITqvarsym (m,n) : lexIface buf + ITbang -> ITqvarsym (m,SLIT("!")) : lexIface buf + _ -> ITunknown (show token) : lexIface buf + +------------ +ifaceKeywordsFM :: UniqFM IfaceToken +ifaceKeywordsFM = listToUFM $ + map (\ (x,y) -> (_PK_ x,y)) + [("/\\_", ITbiglam) ,("@_", ITatsign) ,("interface_", ITinterface) ,("usages_", ITusages) @@ -348,8 +733,9 @@ lexIface input ,("casm_GC_", ITccall (True, True)) ] - haskellKeywordsFM = listToFM [ - ("data", ITdata) +haskellKeywordsFM = listToUFM $ + map (\ (x,y) -> (_PK_ x,y)) + [ ("data", ITdata) ,("type", ITtype) ,("newtype", ITnewtype) ,("class", ITclass) @@ -374,18 +760,33 @@ lexIface input ,("=", ITequal) ] -startDiscard ITarity = True -startDiscard ITunfold = True -startDiscard ITstrict = True -startDiscard other = False -- doDiscard rips along really fast looking for a double semicolon, -- indicating the end of the pragma we're skipping -doDiscard rest@(';' : ';' : _) = rest -doDiscard ( _ : rest) = doDiscard rest -doDiscard [] = [] +doDiscard buf = + case currentChar# buf of + ';'# -> + case lookAhead# buf 1# of + ';'# -> stepOnBy# buf 2# + _ -> doDiscard (stepOn buf) + _ -> doDiscard (stepOn buf) + \end{code} +begin{code} +my_span :: (a -> Bool) -> [a] -> ([a],[a]) +my_span p xs = go [] xs + where + go so_far (x:xs') | p x = go (x:so_far) xs' + go so_far xs = (reverse so_far, xs) + +my_span' :: (a -> Bool) -> [a] -> ([a],Int,[a]) +my_span' p xs = go [] 0 xs + where + go so_far n (x:xs') | p x = go (x:so_far) (n+1) xs' + go so_far n xs = (reverse so_far,n, xs) +end{code} + %************************************************************************ %* * @@ -410,5 +811,5 @@ happyError ln toks = Failed (ifaceParseErr ln toks) ----------------------------------------------------------------- ifaceParseErr ln toks sty - = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))] + = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppPStr SLIT("toks="), ppStr (show (take 10 toks))] \end{code} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 9b72fa5f2a..1892af89cc 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -45,7 +45,7 @@ cvValSig (RdrTySig vars poly_ty src_loc) = [ Sig v poly_ty src_loc | v <- vars ] cvClassOpSig (RdrTySig vars poly_ty src_loc) - = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ] + = [ ClassOpSig v v poly_ty src_loc | v <- vars ] cvInstDeclSig (RdrSpecValSig sigs) = sigs cvInstDeclSig (RdrInlineValSig sig) = [ sig ] diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index ab07b885e6..d7bbd7f981 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -33,7 +33,6 @@ module RdrHsSyn ( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNamePat), SYN_IE(RdrNameHsType), - SYN_IE(RdrNameQual), SYN_IE(RdrNameSig), SYN_IE(RdrNameSpecInstSig), SYN_IE(RdrNameStmt), @@ -51,8 +50,8 @@ module RdrHsSyn ( qual, varQual, tcQual, varUnqual, dummyRdrVarName, dummyRdrTcName, isUnqual, isQual, - showRdr, rdrNameOcc, - cmpRdr, + showRdr, rdrNameOcc, ieOcc, + cmpRdr, prefixRdrName, mkOpApp ) where @@ -63,7 +62,7 @@ import HsSyn import Lex import PrelMods ( pRELUDE ) import Name ( ExportFlag(..), Module(..), pprModule, - OccName(..), pprOccName ) + OccName(..), pprOccName, prefixOccName ) import Pretty import PprStyle ( PprStyle(..) ) import Util ( cmpPString, panic, thenCmp ) @@ -93,7 +92,6 @@ type RdrNameMatch = Match Fake Fake RdrName RdrNamePat type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName -type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat type RdrNameSig = Sig RdrName type RdrNameSpecInstSig = SpecInstSig RdrName type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat @@ -173,6 +171,11 @@ isUnqual (Qual _ _) = False isQual (Unqual _) = False isQual (Qual _ _) = True + -- Used for adding a prefix to a RdrName +prefixRdrName :: FAST_STRING -> RdrName -> RdrName +prefixRdrName prefix (Qual m n) = Qual m (prefixOccName prefix n) +prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n) + cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2 cmpRdr (Unqual n1) (Qual m2 n2) = LT_ cmpRdr (Qual m1 n1) (Unqual n2) = GT_ @@ -183,6 +186,9 @@ rdrNameOcc :: RdrName -> OccName rdrNameOcc (Unqual occ) = occ rdrNameOcc (Qual _ occ) = occ +ieOcc :: RdrNameIE -> OccName +ieOcc ie = rdrNameOcc (ieName ie) + instance Text RdrName where -- debugging showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn)) @@ -201,7 +207,7 @@ instance Ord3 RdrName where instance Outputable RdrName where ppr sty (Unqual n) = pprOccName sty n - ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n] + ppr sty (Qual m n) = ppBesides [pprModule sty m, ppChar '.', pprOccName sty n] instance NamedThing RdrName where -- Just so that pretty-printing of expressions works getOccName = rdrNameOcc diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 2098692e77..d72394f920 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -95,7 +95,7 @@ cvFlag 1 = True # define PACK_STR packCString # define CCALL_THEN `stThen` #else -# define PACK_STR _packCString +# define PACK_STR mkFastCharString # define CCALL_THEN `thenPrimIO` #endif @@ -222,7 +222,7 @@ wlkExpr expr U_doe gdo srcline -> -- do expression mkSrcLocUgn srcline $ \ src_loc -> wlkList rd_stmt gdo `thenUgn` \ stmts -> - returnUgn (HsDo stmts src_loc) + returnUgn (HsDo DoStmt stmts src_loc) where rd_stmt pt = rdU_tree pt `thenUgn` \ bind -> @@ -249,7 +249,8 @@ wlkExpr expr U_comprh cexp cquals -> -- list comprehension wlkExpr cexp `thenUgn` \ expr -> wlkList rd_qual cquals `thenUgn` \ quals -> - returnUgn (ListComp expr quals) + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc) where rd_qual pt = rdU_tree pt `thenUgn` \ qual -> @@ -259,12 +260,14 @@ wlkExpr expr = case qual of U_guard exp -> wlkExpr exp `thenUgn` \ expr -> - returnUgn (FilterQual expr) + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (GuardStmt expr loc) U_qual qpat qexp -> wlkPat qpat `thenUgn` \ pat -> wlkExpr qexp `thenUgn` \ expr -> - returnUgn (GeneratorQual pat expr) + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (BindStmt pat expr loc) U_seqlet seqlet -> wlkBinding seqlet `thenUgn` \ bs -> @@ -272,7 +275,7 @@ wlkExpr expr let binds = cvBinds sf cvValSig bs in - returnUgn (LetQual binds) + returnUgn (LetStmt binds) U_eenum efrom estep eto -> -- arithmetic sequence wlkExpr efrom `thenUgn` \ e1 -> @@ -386,6 +389,11 @@ wlkPat pat wlkPat lazyp `thenUgn` \ pat -> returnUgn (LazyPatIn pat) + U_plusp avar lit -> + wlkVarId avar `thenUgn` \ var -> + wlkLiteral lit `thenUgn` \ lit -> + returnUgn (NPlusKPatIn var lit) + U_wildp -> returnUgn WildPatIn -- wildcard pattern U_lit lit -> -- literal pattern diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 0faa549453..5107c5bc0f 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,6 +1,5 @@ { #include "HsVersions.h" - module ParseIface ( parseIface ) where IMP_Ubiq(){-uitous-} @@ -25,14 +24,16 @@ import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName(..), Provenance ) +import Name ( OccName(..), isTCOcc, Provenance ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( panic{-, pprPanic ToDo:rm-} ) - +import ParseType ( parseType ) +import ParseUnfolding ( parseUnfolding ) +import Maybes ----------------------------------------------------------------- -parseIface = parseIToks . lexIface +parseIface ls = parseIToks (lexIface ls) ----------------------------------------------------------------- } @@ -51,33 +52,33 @@ parseIface = parseIToks . lexIface FIXITIES_PART { ITfixities } DECLARATIONS_PART { ITdeclarations } PRAGMAS_PART { ITpragmas } - BANG { ITbang } - CBRACK { ITcbrack } - CCURLY { ITccurly } + DATA { ITdata } + TYPE { ITtype } + NEWTYPE { ITnewtype } + DERIVING { ITderiving } CLASS { ITclass } + WHERE { ITwhere } + INSTANCE { ITinstance } + INFIXL { ITinfixl } + INFIXR { ITinfixr } + INFIX { ITinfix } + FORALL { ITforall } + BANG { ITbang } + VBAR { ITvbar } + DCOLON { ITdcolon } COMMA { ITcomma } - CPAREN { ITcparen } DARROW { ITdarrow } - DATA { ITdata } - DCOLON { ITdcolon } - DERIVING { ITderiving } DOTDOT { ITdotdot } EQUAL { ITequal } - FORALL { ITforall } - INFIX { ITinfix } - INFIXL { ITinfixl } - INFIXR { ITinfixr } - INSTANCE { ITinstance } - NEWTYPE { ITnewtype } - OBRACK { ITobrack } OCURLY { ITocurly } + OBRACK { ITobrack } OPAREN { IToparen } RARROW { ITrarrow } + CCURLY { ITccurly } + CBRACK { ITcbrack } + CPAREN { ITcparen } SEMI { ITsemi } - TYPE { ITtype } - VBAR { ITvbar } - WHERE { ITwhere } - INTEGER { ITinteger $$ } + VARID { ITvarid $$ } CONID { ITconid $$ } VARSYM { ITvarsym $$ } @@ -87,6 +88,8 @@ parseIface = parseIToks . lexIface QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } + IDINFO_PART { ITidinfo $$ } + TYPE_PART { ITtysig $$ } ARITY_PART { ITarity } STRICT_PART { ITstrict } UNFOLD_PART { ITunfold } @@ -96,23 +99,29 @@ parseIface = parseIToks . lexIface BIGLAM { ITbiglam } CASE { ITcase } PRIM_CASE { ITprim_case } - OF { ITof } LET { ITlet } LETREC { ITletrec } IN { ITin } - ATSIGN { ITatsign } + OF { ITof } COERCE_IN { ITcoerce_in } COERCE_OUT { ITcoerce_out } + ATSIGN { ITatsign } + CCALL { ITccall $$ } + SCC { ITscc $$ } + CHAR { ITchar $$ } STRING { ITstring $$ } + INTEGER { ITinteger $$ } DOUBLE { ITdouble $$ } + INTEGER_LIT { ITinteger_lit } - STRING_LIT { ITstring_lit } FLOAT_LIT { ITfloat_lit } RATIONAL_LIT { ITrational_lit } ADDR_LIT { ITaddr_lit } LIT_LIT { ITlit_lit } - CCALL { ITccall $$ } + STRING_LIT { ITstring_lit } + + UNKNOWN { ITunknown $$ } %% iface :: { ParsedIface } @@ -172,11 +181,14 @@ entities : { [] } | entity entities { $1 : $2 } entity :: { (OccName, [OccName]) } -entity : entity_occ maybe_inside { ($1, $2) } - -maybe_inside :: { [OccName] } -maybe_inside : { [] } - | OPAREN val_occs CPAREN { $2 +entity : entity_occ { ($1, if isTCOcc $1 + then [$1] {- AvailTC -} + else []) {- Avail -} } + | entity_occ stuff_inside { ($1, ($1 : $2)) {- TyCls exported too -} } + | entity_occ BANG stuff_inside { ($1, $3) {- TyCls not exported -} } + +stuff_inside :: { [OccName] } +stuff_inside : OPAREN val_occs1 CPAREN { $2 -------------------------------------------------------------------------- } @@ -219,23 +231,28 @@ version : INTEGER { fromInteger $1 } topdecl :: { RdrNameHsDecl } topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI { TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) } - | DATA decl_context tc_name tv_bndrs EQUAL constrs deriving SEMI - { TyD (TyData $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } + | DATA decl_context tc_name tv_bndrs constrs deriving SEMI + { TyD (TyData $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } | NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } | CLASS decl_context tc_name tv_bndr csigs SEMI { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } - | var_name DCOLON type id_info SEMI SEMI - { {- Double semicolon allows easy pragma discard in lexer -} - let - id_info = if opt_IgnoreIfacePragmas then [] else $4 - in - SigD (IfaceSig $1 $3 id_info mkIfaceSrcLoc) } + | var_name TYPE_PART id_info + { + let + (Succeeded tp) = parseType $2 + in + SigD (IfaceSig $1 tp $3 mkIfaceSrcLoc) } + +id_info :: { [HsIdInfo RdrName] } +id_info : { [] } + | IDINFO_PART { let { (Succeeded id_info) = parseUnfolding $1 } in id_info} decl_context :: { RdrNameContext } decl_context : { [] } | OCURLY context_list1 CCURLY DARROW { $2 } + csigs :: { [RdrNameSig] } csigs : { [] } | WHERE OCURLY csigs1 CCURLY { $3 } @@ -245,13 +262,17 @@ csigs1 : csig { [$1] } | csig SEMI csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : var_name DCOLON type { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc +csig : var_name DCOLON type { ClassOpSig $1 $1 $3 mkIfaceSrcLoc ---------------------------------------------------------------- } constrs :: { [RdrNameConDecl] } -constrs : constr { [$1] } - | constr VBAR constrs { $1 : $3 } + : { [] } + | EQUAL constrs1 { $2 } + +constrs1 :: { [RdrNameConDecl] } +constrs1 : constr { [$1] } + | constr VBAR constrs1 { $1 : $3 } constr :: { RdrNameConDecl } constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc } @@ -349,9 +370,9 @@ val_occ : var_occ { $1 } | CONID { VarOcc $1 } | CONSYM { VarOcc $1 } -val_occs :: { [OccName] } - : { [] } - | val_occ val_occs { $1 : $2 } +val_occs1 :: { [OccName] } + : val_occ { [$1] } + | val_occ val_occs1 { $1 : $2 } qvar_name :: { RdrName } @@ -431,123 +452,3 @@ instd : INSTANCE type EQUAL var_name SEMI mkIfaceSrcLoc -------------------------------------------------------------------------- } - -id_info :: { [HsIdInfo RdrName] } -id_info : { [] } - | id_info_item id_info { $1 : $2 } - -id_info_item :: { HsIdInfo RdrName } -id_info_item : ARITY_PART arity_info { HsArity $2 } - | STRICT_PART strict_info { HsStrictness $2 } - | BOTTOM { HsStrictness mkBottomStrictnessInfo } - | UNFOLD_PART core_expr { HsUnfold $2 } - -arity_info :: { ArityInfo } -arity_info : INTEGER { exactArity (fromInteger $1) } - -strict_info :: { StrictnessInfo RdrName } -strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) } - | DEMAND { mkStrictnessInfo $1 Nothing } - -core_expr :: { UfExpr RdrName } -core_expr : any_var_name { UfVar $1 } - | qdata_name { UfVar $1 } - | core_lit { UfLit $1 } - | OPAREN core_expr CPAREN { $2 } - - | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } - | core_expr core_arg { UfApp $1 $2 } - | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } - | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } - - | CASE core_expr OF - OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } - | PRIM_CASE core_expr OF - OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } - - - | LET OCURLY core_val_bndr EQUAL core_expr CCURLY - IN core_expr { UfLet (UfNonRec $3 $5) $8 } - | LETREC OCURLY rec_binds CCURLY - IN core_expr { UfLet (UfRec $3) $6 } - - | coerce atype core_expr { UfCoerce $1 $2 $3 } - - | CCALL ccall_string - OBRACK atype atypes CBRACK core_args { let - (is_casm, may_gc) = $1 - in - UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) - $7 - } - -rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } - : { [] } - | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } - -coerce :: { UfCoercion RdrName } -coerce : COERCE_IN qdata_name { UfIn $2 } - | COERCE_OUT qdata_name { UfOut $2 } - -prim_alts :: { [(Literal,UfExpr RdrName)] } - : { [] } - | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } - -alg_alts :: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] } - : { [] } - | qdata_name core_val_bndrs RARROW - core_expr SEMI alg_alts { ($1,$2,$4) : $6 } - -core_default :: { UfDefault RdrName } - : { UfNoDefault } - | core_val_bndr RARROW core_expr SEMI { UfBindDefault $1 $3 } - -core_arg :: { UfArg RdrName } - : var_name { UfVarArg $1 } - | qvar_name { UfVarArg $1 } - | qdata_name { UfVarArg $1 } - | core_lit { UfLitArg $1 } - -core_args :: { [UfArg RdrName] } - : { [] } - | core_arg core_args { $1 : $2 } - -core_lit :: { Literal } -core_lit : INTEGER { MachInt $1 True } - | CHAR { MachChar $1 } - | STRING { MachStr $1 } - | STRING_LIT STRING { NoRepStr $2 } - | DOUBLE { MachDouble (toRational $1) } - | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } - - | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") - -- The type checker will add the types - } - - | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) - (panic "NoRepRational type") - -- The type checker will add the type - } - - | ADDR_LIT INTEGER { MachAddr $2 } - | LIT_LIT STRING { MachLitLit $2 (panic "ParseIface.y: ToDo: need PrimRep on LitLits in ifaces") } - -core_val_bndr :: { UfBinder RdrName } -core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } - -core_val_bndrs :: { [UfBinder RdrName] } -core_val_bndrs : { [] } - | core_val_bndr core_val_bndrs { $1 : $2 } - -core_tv_bndr :: { UfBinder RdrName } -core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } - | tv_name { UfTyBinder $1 mkTypeKind } - -core_tv_bndrs :: { [UfBinder RdrName] } -core_tv_bndrs : { [] } - | core_tv_bndr core_tv_bndrs { $1 : $2 } - -ccall_string :: { FAST_STRING } - : STRING { $1 } - | VARID { $1 } - | CONID { $1 } diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y new file mode 100644 index 0000000000..d39c56b53a --- /dev/null +++ b/ghc/compiler/rename/ParseType.y @@ -0,0 +1,140 @@ +{ +#include "HsVersions.h" +module ParseType ( parseType ) where + +IMP_Ubiq(){-uitous-} + +import HsSyn -- quite a bit of stuff +import RdrHsSyn -- oodles of synonyms +import HsDecls ( HsIdInfo(..) ) +import HsTypes ( mkHsForAllTy ) +import HsCore +import Literal +import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) +import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, + ArgUsageInfo, FBTypeInfo + ) +import Kind ( Kind, mkArrowKind, mkTypeKind ) +import Lex + +import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), + SYN_IE(RdrNamePragma), SYN_IE(ExportItem) + ) +import Bag ( emptyBag, unitBag, snocBag ) +import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) +import Name ( OccName(..), isTCOcc, Provenance ) +import SrcLoc ( mkIfaceSrcLoc ) +import Util ( panic{-, pprPanic ToDo:rm-} ) +import Pretty ( ppShow ) +import PprStyle -- PprDebug for panic +import Maybes ( MaybeErr(..) ) + +------------------------------------------------------------------ + +parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Int -> Bool -> PrettyRep) +parseType ls = + let + res = + case parseT ls of + v@(Succeeded _) -> v + Failed err -> panic (ppShow 80 (err PprDebug)) + in + res + +} + +%name parseT +%tokentype { IfaceToken } +%monad { IfM }{ thenIf }{ returnIf } + +%token + FORALL { ITforall } + DCOLON { ITdcolon } + COMMA { ITcomma } + DARROW { ITdarrow } + OCURLY { ITocurly } + OBRACK { ITobrack } + OPAREN { IToparen } + RARROW { ITrarrow } + CCURLY { ITccurly } + CBRACK { ITcbrack } + CPAREN { ITcparen } + + VARID { ITvarid $$ } + CONID { ITconid $$ } + VARSYM { ITvarsym $$ } + CONSYM { ITconsym $$ } + QCONID { ITqconid $$ } + + UNKNOWN { ITunknown $$ } +%% + +type :: { RdrNameHsType } +type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } + | tautype { $1 } + +forall : OBRACK tv_bndrs CBRACK { $2 } + +context :: { RdrNameContext } +context : { [] } + | OCURLY context_list1 CCURLY { $2 } + +context_list1 :: { RdrNameContext } +context_list1 : class { [$1] } + | class COMMA context_list1 { $1 : $3 } + +class :: { (RdrName, RdrNameHsType) } +class : qtc_name atype { ($1, $2) } + + +tautype :: { RdrNameHsType } +tautype : btype { $1 } + | btype RARROW tautype { MonoFunTy $1 $3 } + +types2 :: { [RdrNameHsType] {- Two or more -} } +types2 : type COMMA type { [$1,$3] } + | type COMMA types2 { $1 : $3 } + +btype :: { RdrNameHsType } +btype : atype { $1 } + | btype atype { MonoTyApp $1 $2 } + +atype :: { RdrNameHsType } +atype : qtc_name { MonoTyVar $1 } + | tv_name { MonoTyVar $1 } + | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } + | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } + | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OPAREN type CPAREN { $2 } + +atypes :: { [RdrNameHsType] {- Zero or more -} } +atypes : { [] } + | atype atypes { $1 : $2 +--------------------------------------------------------------------- + } + +tv_bndr :: { HsTyVar RdrName } +tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } + | tv_name { UserTyVar $1 } + +tv_bndrs :: { [HsTyVar RdrName] } + : { [] } + | tv_bndr tv_bndrs { $1 : $2 } + +kind :: { Kind } + : akind { $1 } + | akind RARROW kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} } + | OPAREN kind CPAREN { $2 } + +tv_name :: { RdrName } +tv_name : VARID { Unqual (TvOcc $1) } + +tv_names :: { [RdrName] } + : { [] } + | tv_name tv_names { $1 : $2 } +qtc_name :: { RdrName } +qtc_name : QCONID { tcQual $1 } + diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y new file mode 100644 index 0000000000..1336fb9f51 --- /dev/null +++ b/ghc/compiler/rename/ParseUnfolding.y @@ -0,0 +1,344 @@ +{ +#include "HsVersions.h" +module ParseUnfolding ( parseUnfolding ) where + +IMP_Ubiq(){-uitous-} + +import HsSyn -- quite a bit of stuff +import RdrHsSyn -- oodles of synonyms +import HsDecls ( HsIdInfo(..) ) +import HsTypes ( mkHsForAllTy ) +import HsCore +import Literal +import PrimRep ( decodePrimRep ) +import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) +import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, + ArgUsageInfo, FBTypeInfo + ) +import Kind ( Kind, mkArrowKind, mkTypeKind ) +import Lex + +import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), + SYN_IE(RdrNamePragma), SYN_IE(ExportItem) + ) +import Bag ( emptyBag, unitBag, snocBag ) +import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) +import Name ( OccName(..), isTCOcc, Provenance ) +import SrcLoc ( mkIfaceSrcLoc ) +import Util ( panic{-, pprPanic ToDo:rm-} ) +import Pretty ( ppShow ) +import PprStyle -- PprDebug for panic +import Maybes ( MaybeErr(..) ) + +------------------------------------------------------------------ + +parseUnfolding ls = + let + res = + case parseUnfold ls of + v@(Succeeded _) -> v + -- ill-formed unfolding, crash and burn. + Failed err -> panic (ppShow 80 (err PprDebug)) + in + res +} + +%name parseUnfold +%tokentype { IfaceToken } +%monad { IfM }{ thenIf }{ returnIf } + +%token + PRAGMAS_PART { ITpragmas } + DATA { ITdata } + TYPE { ITtype } + NEWTYPE { ITnewtype } + DERIVING { ITderiving } + CLASS { ITclass } + WHERE { ITwhere } + INSTANCE { ITinstance } + FORALL { ITforall } + BANG { ITbang } + VBAR { ITvbar } + DCOLON { ITdcolon } + COMMA { ITcomma } + DARROW { ITdarrow } + DOTDOT { ITdotdot } + EQUAL { ITequal } + OCURLY { ITocurly } + OBRACK { ITobrack } + OPAREN { IToparen } + RARROW { ITrarrow } + CCURLY { ITccurly } + CBRACK { ITcbrack } + CPAREN { ITcparen } + SEMI { ITsemi } + + VARID { ITvarid $$ } + CONID { ITconid $$ } + VARSYM { ITvarsym $$ } + CONSYM { ITconsym $$ } + QVARID { ITqvarid $$ } + QCONID { ITqconid $$ } + QVARSYM { ITqvarsym $$ } + QCONSYM { ITqconsym $$ } + + ARITY_PART { ITarity } + STRICT_PART { ITstrict } + UNFOLD_PART { ITunfold } + DEMAND { ITdemand $$ } + BOTTOM { ITbottom } + LAM { ITlam } + BIGLAM { ITbiglam } + CASE { ITcase } + PRIM_CASE { ITprim_case } + LET { ITlet } + LETREC { ITletrec } + IN { ITin } + OF { ITof } + COERCE_IN { ITcoerce_in } + COERCE_OUT { ITcoerce_out } + ATSIGN { ITatsign } + CCALL { ITccall $$ } + SCC { ITscc $$ } + + CHAR { ITchar $$ } + STRING { ITstring $$ } + INTEGER { ITinteger $$ } + DOUBLE { ITdouble $$ } + + INTEGER_LIT { ITinteger_lit } + FLOAT_LIT { ITfloat_lit } + RATIONAL_LIT { ITrational_lit } + ADDR_LIT { ITaddr_lit } + LIT_LIT { ITlit_lit } + STRING_LIT { ITstring_lit } + + UNKNOWN { ITunknown $$ } +%% + +id_info :: { [HsIdInfo RdrName] } +id_info : { [] } + | id_info_item id_info { $1 : $2 } + +id_info_item :: { HsIdInfo RdrName } +id_info_item : ARITY_PART arity_info { HsArity $2 } + | STRICT_PART strict_info { HsStrictness $2 } + | BOTTOM { HsStrictness mkBottomStrictnessInfo } + | UNFOLD_PART core_expr { HsUnfold $2 } + +arity_info :: { ArityInfo } +arity_info : INTEGER { exactArity (fromInteger $1) } + +strict_info :: { StrictnessInfo RdrName } +strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) } + | DEMAND { mkStrictnessInfo $1 Nothing } + +core_expr :: { UfExpr RdrName } +core_expr : any_var_name { UfVar $1 } + | qdata_name { UfVar $1 } + | core_lit { UfLit $1 } + | OPAREN core_expr CPAREN { $2 } + | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 } + + | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } + | core_expr core_arg { UfApp $1 $2 } + | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } + | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } + + | CASE core_expr OF + OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } + | PRIM_CASE core_expr OF + OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } + + + | LET OCURLY core_val_bndr EQUAL core_expr CCURLY + IN core_expr { UfLet (UfNonRec $3 $5) $8 } + | LETREC OCURLY rec_binds CCURLY + IN core_expr { UfLet (UfRec $3) $6 } + + | coerce atype core_expr { UfCoerce $1 $2 $3 } + + | CCALL ccall_string + OBRACK atype atypes CBRACK core_args { let + (is_casm, may_gc) = $1 + in + UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) + $7 + } + | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 } + +rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } + : { [] } + | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } + +coerce :: { UfCoercion RdrName } +coerce : COERCE_IN qdata_name { UfIn $2 } + | COERCE_OUT qdata_name { UfOut $2 } + +prim_alts :: { [(Literal,UfExpr RdrName)] } + : { [] } + | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } + +alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] } + : { [] } + | qdata_name var_names RARROW + core_expr SEMI alg_alts { ($1,$2,$4) : $6 } + +core_default :: { UfDefault RdrName } + : { UfNoDefault } + | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 } + +core_arg :: { UfArg RdrName } + : var_name { UfVarArg $1 } + | qvar_name { UfVarArg $1 } + | qdata_name { UfVarArg $1 } + | core_lit { UfLitArg $1 } + +core_args :: { [UfArg RdrName] } + : { [] } + | core_arg core_args { $1 : $2 } + +data_args :: { [UfArg RdrName] } + : { [] } + | ATSIGN atype data_args { UfTyArg $2 : $3 } + | core_arg data_args { $1 : $2 } + +core_lit :: { Literal } +core_lit : INTEGER { MachInt $1 True } + | CHAR { MachChar $1 } + | STRING { MachStr $1 } + | STRING_LIT STRING { NoRepStr $2 } + | DOUBLE { MachDouble (toRational $1) } + | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } + + | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") + -- The type checker will add the types + } + + | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) + (panic "NoRepRational type") + -- The type checker will add the type + } + + | ADDR_LIT INTEGER { MachAddr $2 } + | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) } + +core_val_bndr :: { UfBinder RdrName } +core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } + +core_val_bndrs :: { [UfBinder RdrName] } +core_val_bndrs : { [] } + | core_val_bndr core_val_bndrs { $1 : $2 } + +core_tv_bndr :: { UfBinder RdrName } +core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } + | tv_name { UfTyBinder $1 mkTypeKind } + +core_tv_bndrs :: { [UfBinder RdrName] } +core_tv_bndrs : { [] } + | core_tv_bndr core_tv_bndrs { $1 : $2 } + +ccall_string :: { FAST_STRING } + : STRING { $1 } + | VARID { $1 } + | CONID { $1 } + +prim_rep :: { Char } + : VARID { head (_UNPK_ $1) } + | CONID { head (_UNPK_ $1) + +---variable names----------------------------------------------------- + } +var_occ :: { OccName } +var_occ : VARID { VarOcc $1 } + | VARSYM { VarOcc $1 } + | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} } + +qdata_name :: { RdrName } +qdata_name : QCONID { varQual $1 } + | QCONSYM { varQual $1 } + +qvar_name :: { RdrName } + : QVARID { varQual $1 } + | QVARSYM { varQual $1 } + +var_name :: { RdrName } +var_name : var_occ { Unqual $1 } + +any_var_name :: {RdrName} +any_var_name : var_name { $1 } + | qvar_name { $1 } + +var_names :: { [RdrName] } +var_names : { [] } + | var_name var_names { $1 : $2 + +--productions-for-types-------------------------------- + } +forall : OBRACK tv_bndrs CBRACK { $2 } + +context :: { RdrNameContext } +context : { [] } + | OCURLY context_list1 CCURLY { $2 } + +context_list1 :: { RdrNameContext } +context_list1 : class { [$1] } + | class COMMA context_list1 { $1 : $3 } + +class :: { (RdrName, RdrNameHsType) } +class : qtc_name atype { ($1, $2) } + +type :: { RdrNameHsType } +type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } + | tautype { $1 } + +tautype :: { RdrNameHsType } +tautype : btype { $1 } + | btype RARROW tautype { MonoFunTy $1 $3 } + +types2 :: { [RdrNameHsType] {- Two or more -} } +types2 : type COMMA type { [$1,$3] } + | type COMMA types2 { $1 : $3 } + +btype :: { RdrNameHsType } +btype : atype { $1 } + | btype atype { MonoTyApp $1 $2 } + +atype :: { RdrNameHsType } +atype : qtc_name { MonoTyVar $1 } + | tv_name { MonoTyVar $1 } + | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } + | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } + | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OPAREN type CPAREN { $2 } + +atypes :: { [RdrNameHsType] {- Zero or more -} } +atypes : { [] } + | atype atypes { $1 : $2 +--------------------------------------------------------------------- + } + +tv_bndr :: { HsTyVar RdrName } +tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } + | tv_name { UserTyVar $1 } + +tv_bndrs :: { [HsTyVar RdrName] } + : { [] } + | tv_bndr tv_bndrs { $1 : $2 } + +kind :: { Kind } + : akind { $1 } + | akind RARROW kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} } + | OPAREN kind CPAREN { $2 } + +tv_name :: { RdrName } +tv_name : VARID { Unqual (TvOcc $1) } + +tv_names :: { [RdrName] } + : { [] } + | tv_name tv_names { $1 : $2 } +qtc_name :: { RdrName } +qtc_name : QCONID { tcQual $1 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index d66596bc3f..81059c201e 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -21,8 +21,8 @@ import CmdLineOpts ( opt_HiMap ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnDecl ) -import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules, - mkSearchPath, getWiredInDecl +import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules, + mkSearchPath ) import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn, lookupImplicitOccRn ) @@ -81,34 +81,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ ) `thenRn` \ rn_local_decls -> -- SLURP IN ALL THE NEEDED DECLARATIONS - -- Notice that the rnEnv starts empty - closeDecls rn_local_decls (availsToNameSet local_avails) [] - `thenRn` \ (rn_all_decls1, all_names1, imp_avails1) -> - - -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS - -- We extract instance decls that only mention things (type constructors, classes) that are - -- already imported. Those that don't can't possibly be useful to us. - -- - -- We do another closeDecls, so that we can slurp info for the dictionary functions - -- for the instance declaration. These are *not* optional because the version number on - -- the dfun acts as the version number for the instance declaration itself; if the - -- instance decl changes, so will its dfun version number. - getImportedInstDecls `thenRn` \ imported_insts -> - let - all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets` - mkNameSet [name | Avail name _ <- imp_avails1] - - rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl)) - | (inst_names, mod_name, inst_decl) <- imported_insts, - all (`elemNameSet` all_big_names) inst_names - ] - in - sequenceRn rn_needed_insts `thenRn` \ inst_decls -> - closeDecls rn_all_decls1 all_names1 imp_avails1 `thenRn` \ (rn_all_decls2, all_names2, imp_avails2) -> + closeDecls rn_local_decls `thenRn` \ rn_all_decls -> -- GENERATE THE VERSION/USAGE INFO - getImportVersions imp_avails2 `thenRn` \ import_versions -> + getImportVersions mod_name exports `thenRn` \ import_versions -> getNameSupplyRn `thenRn` \ name_supply -> @@ -133,7 +110,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ renamed_module = HsModule mod_name vers trashed_exports trashed_imports trashed_fixities - (inst_decls ++ rn_all_decls2) + rn_all_decls loc in returnRn (Just (renamed_module, @@ -169,62 +146,56 @@ addImplicits mod_name \begin{code} closeDecls :: [RenamedHsDecl] -- Declarations got so far - -> NameSet -- Names bound by those declarations - -> [AvailInfo] -- Available stuff generated by closeDecls so far - -> RnMG ([RenamedHsDecl], -- input + extra decls slurped - NameSet, -- input + names bound by extra decls - [AvailInfo]) -- input + extra avails from extra decls + -> RnMG [RenamedHsDecl] -- input + extra decls slurped -- The monad includes a list of possibly-unresolved Names -- This list is empty when closeDecls returns -closeDecls decls decl_names import_avails +closeDecls decls = popOccurrenceName `thenRn` \ maybe_unresolved -> - case maybe_unresolved of - -- No more unresolved names; we're done - Nothing -> returnRn (decls, decl_names, import_avails) - - -- An "unresolved" name that we've already dealt with - Just (name,_) | name `elemNameSet` decl_names - -> closeDecls decls decl_names import_avails + -- No more unresolved names + Nothing -> -- Slurp instance declarations + getImportedInstDecls `thenRn` \ inst_decls -> + traceRn (ppSep [ppPStr SLIT("Slurped"), ppInt (length inst_decls), ppPStr SLIT("instance decls")]) + `thenRn_` + + -- None? then at last we are done + if null inst_decls then + returnRn decls + else + mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls -> + + -- We *must* loop again here. Why? Two reasons: + -- (a) an instance decl will give rise to an unresolved dfun, whose + -- decl we must slurp to get its version number; that's the version + -- number for the whole instance decl. + -- (b) an instance decl might give rise to a new unresolved class, + -- whose decl we must slurp, which might let in some new instance decls, + -- and so on. Example: instance Foo a => Baz [a] where ... - -- An unresolved name that's wired in. In this case there's no - -- declaration to get, but we still want to record it as now available, - -- so that we remember to look for instance declarations involving it. - Just (name,_) | isWiredInName name - -> getWiredInDecl name `thenRn` \ decl_avail -> - closeDecls decls - (addAvailToNameSet decl_names decl_avail) - (decl_avail : import_avails) - - -- Genuinely unresolved name - Just (name,necessity) | otherwise - -> getDecl name `thenRn` \ (decl_avail,new_decl) -> - case decl_avail of - - -- Can't find the declaration; check that it was optional - NotAvailable -> case necessity of { - Optional -> addWarnRn (getDeclWarn name); - other -> addErrRn (getDeclErr name) - } `thenRn_` - closeDecls decls decl_names import_avails - - -- Found it - other -> initRnMS emptyRnEnv mod_name InterfaceMode ( - rnDecl new_decl - ) `thenRn` \ rn_decl -> - closeDecls (rn_decl : decls) - (addAvailToNameSet decl_names decl_avail) - (decl_avail : import_avails) + closeDecls (new_inst_decls ++ decls) + + -- An unresolved name + Just (name,necessity) + -> -- Slurp its declaration, if any +-- traceRn (ppSep [ppPStr SLIT("Considering"), ppr PprDebug name]) `thenRn_` + importDecl name necessity `thenRn` \ maybe_decl -> + case maybe_decl of + + -- No declaration... (wired in thing or optional) + Nothing -> closeDecls decls + + -- Found a declaration... rename it + Just decl -> rn_iface_decl mod_name decl `thenRn` \ new_decl -> + closeDecls (new_decl : decls) where (mod_name,_) = modAndOcc name + where + -- Notice that the rnEnv starts empty + rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl) + rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl) -getDeclErr name sty - = ppSep [ppStr "Failed to find interface decl for", ppr sty name] - -getDeclWarn name sty - = ppSep [ppStr "Warning: failed to find (optional) interface decl for", ppr sty name] \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index d4df584c22..d5183aed30 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -26,7 +26,7 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName ) +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, isUnboundName ) import CmdLineOpts ( opt_SigsRequired ) import Digraph ( stronglyConnComp ) @@ -174,7 +174,7 @@ rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds rnTopMonoBinds mbinds sigs - = mapRn lookupRn binder_rdr_names `thenRn` \ binder_names -> + = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> let binder_set = mkNameSet binder_names in @@ -312,7 +312,7 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ mapRn (checkPrecMatch inf name) matches `thenRn_` - lookupRn name `thenRn` \ name' -> + lookupBndrRn name `thenRn` \ name' -> mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> let fvs = unionManyNameSets fv_lists @@ -346,13 +346,13 @@ rnMethodBinds (AndMonoBinds mb1 mb2) rnMethodBinds (FunMonoBind occname inf matches locn) = pushSrcLocRn locn $ mapRn (checkPrecMatch inf occname) matches `thenRn_` - lookupRn occname `thenRn` \ op_name -> + lookupBndrRn occname `thenRn` \ op_name -> mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> returnRn (FunMonoBind op_name inf new_matches locn) rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn) = pushSrcLocRn locn $ - lookupRn occname `thenRn` \ op_name -> + lookupBndrRn occname `thenRn` \ op_name -> rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) -> returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) @@ -503,13 +503,13 @@ rnBindSigs is_toplev binders sigs renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> rnHsType ty `thenRn` \ new_ty -> returnRn (Sig new_v new_ty src_loc) renameSig (SpecSig v ty using src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> rnHsType ty `thenRn` \ new_ty -> rn_using using `thenRn` \ new_using -> returnRn (SpecSig new_v new_ty new_using src_loc) @@ -520,17 +520,17 @@ renameSig (SpecSig v ty using src_loc) renameSig (InlineSig v src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> returnRn (InlineSig new_v src_loc) renameSig (DeforestSig v src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> returnRn (DeforestSig new_v src_loc) renameSig (MagicUnfoldingSig v str src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> returnRn (MagicUnfoldingSig new_v str src_loc) \end{code} @@ -573,29 +573,29 @@ sig_name (MagicUnfoldingSig n _ _) = n \begin{code} dupSigDeclErr (sig:sigs) = pushSrcLocRn loc $ - addErrRn (\sty -> ppSep [ppStr "more than one", - ppStr what_it_is, ppStr "given for", - ppQuote (ppr sty (sig_name sig))]) + addErrRn (\sty -> ppSep [ppPStr SLIT("more than one"), + ppPStr what_it_is, ppPStr SLIT("given for"), + ppQuote (ppr sty (sig_name sig))]) where (what_it_is, loc) = sig_doc sig unknownSigErr sig = pushSrcLocRn loc $ - addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for", + addErrRn (\sty -> ppSep [ppPStr flavour, ppPStr SLIT("but no definition for"), ppQuote (ppr sty (sig_name sig))]) where (flavour, loc) = sig_doc sig -sig_doc (Sig _ _ loc) = ("type signature",loc) -sig_doc (ClassOpSig _ _ _ loc) = ("class-method type signature", loc) -sig_doc (SpecSig _ _ _ loc) = ("SPECIALIZE pragma",loc) -sig_doc (InlineSig _ loc) = ("INLINE pragma",loc) -sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc) +sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) +sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) +sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc) +sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) +sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc) missingSigErr var sty - = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)] + = ppSep [ppPStr SLIT("a definition but no type signature for"), ppQuote (ppr sty var)] methodBindErr mbind sty - = ppHang (ppStr "Can't handle multiple methods defined by one pattern binding") + = ppHang (ppPStr SLIT("Can't handle multiple methods defined by one pattern binding")) 4 (ppr sty mbind) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index da4fed92c0..1b348bccc1 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,18 +10,18 @@ module RnEnv where -- Export everything IMP_Ubiq() -import CmdLineOpts ( opt_WarnNameShadowing, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_WarnNameShadowing ) import HsSyn import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE), - rdrNameOcc, isQual, qual + rdrNameOcc, ieOcc, isQual, qual ) import HsTypes ( getTyVarName, replaceTyVarName ) import RnMonad import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), occNameString, occNameFlavour, SYN_IE(NameSet), emptyNameSet, addListToNameSet, - mkLocalName, mkGlobalName, modAndOcc, - isLocalName, isWiredInName, nameOccName, setNameProvenance, + mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName, + isWiredInName, nameOccName, setNameProvenance, isVarOcc, pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance ) import TyCon ( TyCon ) @@ -49,7 +49,8 @@ newGlobalName :: Module -> OccName -> RnM s d Name newGlobalName mod occ = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - case lookupFM cache (mod,occ) of + let key = (mod,occ) in + case lookupFM cache key of -- A hit in the cache! Return it, but change the src loc -- of the thing we've found if this is a second definition site @@ -63,7 +64,7 @@ newGlobalName mod occ (us', us1) = splitUniqSupply us uniq = getUnique us1 name = mkGlobalName uniq mod occ VanillaDefn Implicit - cache' = addToFM cache (mod,occ) name + cache' = addToFM cache key name in setNameSupplyRn (us', inst_ns, cache') `thenRn_` returnRn name @@ -86,28 +87,50 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc provenance = LocalDef (rec_exp_fn new_name) loc (us', us1) = splitUniqSupply us uniq = getUnique us1 - new_name = case lookupFM cache (mod,occ) of - Just name -> setNameProvenance name provenance - Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance - cache' = addToFM cache (mod,occ) new_name + key = (mod,occ) + new_name = case lookupFM cache key of + Just name -> setNameProvenance name provenance + Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance + new_cache = addToFM cache key new_name in - setNameSupplyRn (us', inst_ns, cache') `thenRn_` + setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn new_name --- newDfunName is used to allocate a name for the dictionary function for --- a local instance declaration. No need to put it in the cache (I think!). -newDfunName :: SrcLoc -> RnMS s Name -newDfunName src_loc - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - getModuleRn `thenRn` \ mod_name -> +-- newSysName is used to create the names for +-- a) default methods +-- These are never mentioned explicitly in source code (hence no point in looking +-- them up in the NameEnv), but when reading an interface file +-- we may want to slurp in their pragma info. In the source file itself we +-- need to create these names too so that we export them into the inferface file for this module. + +newSysName :: OccName -> ExportFlag -> SrcLoc -> RnMS s Name +newSysName occ export_flag loc + = getModeRn `thenRn` \ mode -> + getModuleRn `thenRn` \ mod_name -> + case mode of + SourceMode -> newLocallyDefinedGlobalName + mod_name occ + (\_ -> export_flag) + loc + InterfaceMode -> newGlobalName mod_name occ + +-- newDfunName is a variant, specially for dfuns. +-- When renaming derived definitions we are in *interface* mode (because we can trip +-- over original names), but we still want to make the Dfun locally-defined. +-- So we can't use whether or not we're in source mode to decide the locally-defined question. +newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name +newDfunName Nothing src_loc -- Local instance decls have a "Nothing" + = getModuleRn `thenRn` \ mod_name -> + newInstUniq `thenRn` \ inst_uniq -> let - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - dfun_name = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns))) - VanillaDefn (LocalDef Exported src_loc) - in - setNameSupplyRn (us', inst_ns+1, cache) `thenRn_` - returnRn dfun_name + dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq)) + in + newLocallyDefinedGlobalName mod_name dfun_occ + (\_ -> Exported) src_loc + +newDfunName (Just n) src_loc -- Imported ones have "Just n" + = getModuleRn `thenRn` \ mod_name -> + newGlobalName mod_name (rdrNameOcc n) newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] @@ -189,10 +212,9 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope Looking up a name in the RnEnv. \begin{code} -lookupRn :: RdrName -> RnMS s Name -lookupRn rdr_name - = getNameEnv `thenRn` \ name_env -> - case lookupFM name_env rdr_name of +lookupRn :: NameEnv -> RdrName -> RnMS s Name +lookupRn name_env rdr_name + = case lookupFM name_env rdr_name of -- Found it! Just name -> returnRn name @@ -218,31 +240,37 @@ lookupRn rdr_name newGlobalName mod_name occ +lookupBndrRn rdr_name + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name + -- Just like lookupRn except that we record the occurrence too -- Perhaps surprisingly, even wired-in names are recorded. -- Why? So that we know which wired-in names are referred to when -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = lookupRn rdr_name `thenRn` \ name -> - if isLocalName name then - returnRn name - else - addOccurrenceName Compulsory name `thenRn_` - returnRn name + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName Compulsory name + +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. It's used for record field names only. +lookupGlobalOccRn :: RdrName -> RnMS s Name +lookupGlobalOccRn rdr_name + = getGlobalNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName Compulsory name -- lookupOptionalOccRn is similar, but it's used in places where -- we don't *have* to find a definition for the thing. lookupOptionalOccRn :: RdrName -> RnMS s Name lookupOptionalOccRn rdr_name - = lookupRn rdr_name `thenRn` \ name -> - if opt_IgnoreIfacePragmas || isLocalName name then - -- Never look for optional things if we're - -- ignoring optional input interface information - returnRn name - else - addOccurrenceName Optional name `thenRn_` - returnRn name + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName Optional name + + -- lookupImplicitOccRn takes an RdrName representing an *original* name, and -- adds it to the occurrence pool so that it'll be loaded later. This is @@ -253,7 +281,7 @@ lookupOptionalOccRn rdr_name -- This doesn't apply in interface mode, where everything is explicit, but -- we don't check for this case: it does no harm to record an "extra" occurrence -- and lookupImplicitOccRn isn't used much in interface mode (it's only the --- Nothing clause of rnDerivs that calls it at all I think. +-- Nothing clause of rnDerivs that calls it at all I think). -- -- For List and Tuple types it's important to get the correct -- isLocallyDefined flag, which is used in turn when deciding @@ -263,10 +291,9 @@ lookupOptionalOccRn rdr_name lookupImplicitOccRn :: RdrName -> RnMS s Name lookupImplicitOccRn (Qual mod occ) = newGlobalName mod occ `thenRn` \ name -> - addOccurrenceName Compulsory name `thenRn_` - returnRn name + addOccurrenceName Compulsory name -addImplicitOccRn :: Name -> RnM s d () +addImplicitOccRn :: Name -> RnM s d Name addImplicitOccRn name = addOccurrenceName Compulsory name addImplicitOccsRn :: [Name] -> RnM s d () @@ -357,42 +384,112 @@ lookupModuleAvails = lookupFM =============== AvailInfo ================ \begin{code} -plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2)) +plusAvail (Avail n1) (Avail n2) = Avail n1 +plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) plusAvail a NotAvailable = a plusAvail NotAvailable a = a addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names NotAvailable = names -addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns) +addAvailToNameSet names avail = addListToNameSet names (availNames avail) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _) = n + availNames :: AvailInfo -> [Name] -availNames NotAvailable = [] -availNames (Avail n ns) = n:ns - -filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo -filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable -filterAvail (IEThingWith _ wanted) (Avail n ns) - | sub_names_ok = Avail n (filter is_wanted ns) - | otherwise = NotAvailable +availNames NotAvailable = [] +availNames (Avail n) = [n] +availNames (AvailTC n ns) = ns + +-- availEntityNames is used to extract the names that can appear on their own in +-- an export or import list. For class decls, class methods can appear on their +-- own, thus import A( op ) +-- but constructors cannot; thus +-- import B( T ) +-- means import type T from B, not constructor T. + +availEntityNames :: AvailInfo -> [Name] +availEntityNames NotAvailable = [] +availEntityNames (Avail n) = [n] +availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns + +filterAvail :: RdrNameIE -- Wanted + -> AvailInfo -- Available + -> AvailInfo -- Resulting available; + -- NotAvailable if wanted stuff isn't there + +filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) + | sub_names_ok = AvailTC n (filter is_wanted ns) + | otherwise = pprTrace "filterAvail" (ppCat [ppr PprDebug ie, pprAvail PprDebug avail]) $ + NotAvailable where is_wanted name = nameOccName name `elem` wanted_occs sub_names_ok = all (`elem` avail_occs) wanted_occs - wanted_occs = map rdrNameOcc wanted avail_occs = map nameOccName ns + wanted_occs = map rdrNameOcc (want:wants) + +filterAvail (IEThingAbs _) (AvailTC n ns) + | n `elem` ns = AvailTC n [n] + +filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms + +filterAvail (IEVar _) avail@(Avail n) = avail +filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) + where + wanted n = nameOccName n == occ + occ = rdrNameOcc v + -- The second equation happens if we import a class op, thus + -- import A( op ) + -- where op is a class operation + +filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail + +filterAvail ie avail = NotAvailable + + +hideAvail :: RdrNameIE -- Hide this + -> AvailInfo -- Available + -> AvailInfo -- Resulting available; +-- Don't complain about hiding non-existent things; that's done elsewhere + +hideAvail ie NotAvailable + = NotAvailable + +hideAvail ie (Avail n) + | not (ieOcc ie == nameOccName n) = Avail n -- No match + | otherwise = NotAvailable -- Names match + +hideAvail ie (AvailTC n ns) + | not (ieOcc ie == nameOccName n) -- No match + = case ie of -- But in case we are faced with ...hiding( (+) ) + -- we filter the "ns" anyhow + IEVar op -> AvailTC n (filter keep ns) + where + op_occ = rdrNameOcc op + keep n = nameOccName n /= op_occ + + other -> AvailTC n ns + | otherwise -- Names match + = case ie of + IEThingAbs _ -> AvailTC n (filter (/= n) ns) + IEThingAll _ -> NotAvailable + IEThingWith hide hides -> AvailTC n (filter keep ns) + where + keep n = nameOccName n `notElem` hide_occs + hide_occs = map rdrNameOcc (hide : hides) -filterAvail (IEThingAll _) avail = avail -filterAvail ie (Avail n ns) = Avail n [] -- IEThingAbs and IEVar -- pprAvail gets given the OccName of the "host" thing -pprAvail sty NotAvailable = ppStr "NotAvailable" -pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n), - ppStr "(", - ppInterleave ppComma (map (pprOccName sty.nameOccName) ns), - ppStr ")"] +pprAvail sty NotAvailable = ppPStr SLIT("NotAvailable") +pprAvail sty (AvailTC n ns) = ppCat [pprOccName sty (nameOccName n), + ppChar '(', + ppInterleave ppComma (map (pprOccName sty.nameOccName) ns), + ppChar ')'] +pprAvail sty (Avail n) = pprOccName sty (nameOccName n) \end{code} @@ -436,33 +533,35 @@ conflictFM bad fm key elt \begin{code} nameClashErr (rdr_name, (name1,name2)) sty - = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name]) + = ppHang (ppCat [ppPStr SLIT("Conflicting definitions for: "), ppr sty rdr_name]) 4 (ppAboves [pprNameProvenance sty name1, pprNameProvenance sty name2]) fixityClashErr (rdr_name, (fp1,fp2)) sty - = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name]) + = ppHang (ppCat [ppPStr SLIT("Conflicting fixities for: "), ppr sty rdr_name]) 4 (ppAboves [pprFixityProvenance sty fp1, pprFixityProvenance sty fp2]) shadowedNameWarn shadow sty - = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow] + = ppBesides [ppPStr SLIT("This binding for"), + ppQuote (ppr sty shadow), + ppPStr SLIT("shadows an existing binding")] unknownNameErr name sty - = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name] + = ppSep [ppStr flavour, ppPStr SLIT("not in scope:"), ppr sty name] where flavour = occNameFlavour (rdrNameOcc name) qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ", - ppStr descriptor, ppStr ": ", + addErrRn (\sty -> ppBesides [ppPStr SLIT("invalid use of qualified "), + ppStr descriptor, ppPStr SLIT(": "), pprNonSymOcc sty (rdrNameOcc name) ]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `", - ppr sty name, ppStr "' in ", + addErrRn (\sty -> ppBesides [ppPStr SLIT("duplicate bindings of `"), + ppr sty name, ppPStr SLIT("' in "), ppStr descriptor]) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 73b1c44692..e1e6fe23db 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -26,16 +26,18 @@ import RnHsSyn import RnMonad import RnEnv import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, - creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, + creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, negate_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TyCon ( TyCon ) +import Id ( GenId ) import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name import Pretty +import Unique ( Unique, otherwiseIdKey ) import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, @@ -58,7 +60,7 @@ rnPat :: RdrNamePat -> RnMS s RenamedPat rnPat WildPatIn = returnRn WildPatIn rnPat (VarPatIn name) - = lookupRn name `thenRn` \ vname -> + = lookupBndrRn name `thenRn` \ vname -> returnRn (VarPatIn vname) rnPat (LitPatIn lit) @@ -72,17 +74,17 @@ rnPat (LazyPatIn pat) rnPat (AsPatIn name pat) = rnPat pat `thenRn` \ pat' -> - lookupRn name `thenRn` \ vname -> + lookupBndrRn name `thenRn` \ vname -> returnRn (AsPatIn vname pat') rnPat (ConPatIn con pats) - = lookupRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> mapRn rnPat pats `thenRn` \ patslist -> returnRn (ConPatIn con' patslist) rnPat (ConOpPatIn pat1 con _ pat2) = rnPat pat1 `thenRn` \ pat1' -> - lookupRn con `thenRn` \ con' -> + lookupOccRn con `thenRn` \ con' -> lookupFixity con `thenRn` \ fixity -> rnPat pat2 `thenRn` \ pat2' -> mkConOpPatRn pat1' con' fixity pat2' @@ -105,6 +107,12 @@ rnPat (ParPatIn pat) = rnPat pat `thenRn` \ pat' -> returnRn (ParPatIn pat') +rnPat (NPlusKPatIn name lit) + = litOccurrence lit `thenRn_` + lookupImplicitOccRn ordClass_RDR `thenRn_` + lookupBndrRn name `thenRn` \ name' -> + returnRn (NPlusKPatIn name' lit) + rnPat (ListPatIn pats) = addImplicitOccRn listType_name `thenRn_` mapRn rnPat pats `thenRn` \ patslist -> @@ -116,7 +124,7 @@ rnPat (TuplePatIn pats) returnRn (TuplePatIn patslist) rnPat (RecPatIn con rpats) - = lookupRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ rpats' -> returnRn (RecPatIn con' rpats') \end{code} @@ -168,7 +176,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) = pushSrcLocRn locn $ rnExpr guard `thenRn` \ (guard', fvsg) -> rnExpr expr `thenRn` \ (expr', fvse) -> - returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse) + + -- Turn an "otherwise" guard into an OtherwiseGRHS. + -- This is the first moment that we can be sure we havn't got a shadowed binding + -- of "otherwise". + let grhs' = case guard' of + HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn + other -> GRHS guard' expr' locn + in + returnRn (grhs', fvsg `unionNameSets` fvse) rnGRHS (OtherwiseGRHS expr locn) = pushSrcLocRn locn $ @@ -184,13 +200,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) \begin{code} rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) - -rnExprs [] = returnRn ([], emptyNameSet) - -rnExprs (expr:exprs) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnExprs exprs `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs) +rnExprs ls = + rnExprs' ls [] `thenRn` \ (exprs, fvExprs) -> + returnRn (exprs, unionManyNameSets fvExprs) + +rnExprs' [] acc = returnRn ([], acc) +rnExprs' (expr:exprs) acc + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) -> + returnRn (expr':exprs', fvExprs) \end{code} Variables. We look up the variable and return the resulting name. The @@ -280,16 +298,11 @@ rnExpr (HsLet binds expr) rnExpr expr `thenRn` \ (expr',fvExpr) -> returnRn (HsLet binds' expr', fvExpr) -rnExpr (HsDo stmts src_loc) +rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too rnStmts stmts `thenRn` \ (stmts', fvStmts) -> - returnRn (HsDo stmts' src_loc, fvStmts) - -rnExpr (ListComp expr quals) - = addImplicitOccRn listType_name `thenRn_` - rnQuals expr quals `thenRn` \ ((expr', quals'), fvs) -> - returnRn (ListComp expr' quals', fvs) + returnRn (HsDo do_or_lc stmts' src_loc, fvStmts) rnExpr (ExplicitList exps) = addImplicitOccRn listType_name `thenRn_` @@ -367,7 +380,7 @@ rnRbinds str rbinds field_dup_err dups = addErrRn (dupFieldErr str dups) rn_rbind (field, expr, pun) - = lookupOccRn field `thenRn` \ fieldname -> + = lookupGlobalOccRn field `thenRn` \ fieldname -> rnExpr expr `thenRn` \ (expr', fvExpr) -> returnRn ((fieldname, expr', pun), fvExpr) @@ -380,14 +393,14 @@ rnRpats rpats field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) rn_rpat (field, pat, pun) - = lookupOccRn field `thenRn` \ fieldname -> + = lookupGlobalOccRn field `thenRn` \ fieldname -> rnPat pat `thenRn` \ pat' -> returnRn (fieldname, pat', pun) \end{code} %************************************************************************ %* * -\subsubsection{@Qualifier@s: in list comprehensions} +\subsubsection{@Stmt@s: in @do@ expressions} %* * %************************************************************************ @@ -400,59 +413,9 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -rnQuals :: RdrNameHsExpr -> [RdrNameQual] - -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars) - -rnQuals expr [qual] -- must be at least one qual - = rnQual qual $ \ new_qual -> - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn ((expr', [new_qual]), fvs) - -rnQuals expr (qual: quals) - = rnQual qual $ \ qual' -> - rnQuals expr quals `thenRn` \ ((expr', quals'), fv_quals) -> - returnRn ((expr', qual' : quals'), fv_quals) - - --- rnQual :: RdrNameQual --- -> (RenamedQual -> RnMS s (a,FreeVars)) --- -> RnMS s (a,FreeVars) --- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2] - -rnQual (GeneratorQual pat expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsRn "pattern in list comprehension" binders $ \ new_binders -> - rnPat pat `thenRn` \ pat' -> - - thing_inside (GeneratorQual pat' expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders)) - where - binders = collectPatBinders pat - -rnQual (FilterQual expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (FilterQual expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` fvs) - -rnQual (LetQual binds) thing_inside - = rnBinds binds $ \ binds' -> - thing_inside (LetQual binds') -\end{code} - - -%************************************************************************ -%* * -\subsubsection{@Stmt@s: in @do@ expressions} -%* * -%************************************************************************ - -\begin{code} rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars) -rnStmts [stmt@(ExprStmt expr src_loc)] -- last stmt must be ExprStmt - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - returnRn ([ExprStmt expr' src_loc], fv_expr) +rnStmts [] = returnRn ([], emptyNameSet) rnStmts (stmt:stmts) = rnStmt stmt $ \ stmt' -> @@ -480,6 +443,17 @@ rnStmt (ExprStmt expr src_loc) thing_inside thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `unionNameSets` fvs) +rnStmt (GuardStmt expr src_loc) thing_inside + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + +rnStmt (ReturnStmt expr) thing_inside + = rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> thing_inside (LetStmt binds') @@ -663,12 +637,10 @@ litOccurrence (HsStringPrim _) = addImplicitOccRn (getName addrPrimTyCon) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR `thenRn_` -- Int and Integer are forced in by Num - returnRn () + = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn_` -- ... similarly Rational - returnRn () + = lookupImplicitOccRn fractionalClass_RDR -- ... similarly Rational litOccurrence (HsIntPrim _) = addImplicitOccRn (getName intPrimTyCon) @@ -680,8 +652,7 @@ litOccurrence (HsDoublePrim _) = addImplicitOccRn (getName doublePrimTyCon) litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR `thenRn_` - returnRn () + = lookupImplicitOccRn ccallableClass_RDR \end{code} @@ -693,19 +664,23 @@ litOccurrence (HsLitLit _) \begin{code} dupFieldErr str (dup:rest) sty - = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str] + = ppBesides [ppPStr SLIT("duplicate field name `"), + ppr sty dup, + ppPStr SLIT("' in record "), ppStr str] negPatErr pat sty - = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat] + = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] precParseNegPatErr op sty - = ppHang (ppStr "precedence parsing error") - 4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"]) + = ppHang (ppPStr SLIT("precedence parsing error")) + 4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "), + pp_op sty op, + ppPStr SLIT(" in pattern")]) precParseErr op1 op2 sty - = ppHang (ppStr "precedence parsing error") - 4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2, - ppStr " in the same infix expression"]) + = ppHang (ppPStr SLIT("precedence parsing error")) + 4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2, + ppPStr SLIT(" in the same infix expression")]) pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen] \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index fab6dd1119..953d8add83 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -48,7 +48,6 @@ type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat type RenamedPat = InPat Name type RenamedHsType = HsType Name type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat -type RenamedQual = Qualifier Fake Fake Name RenamedPat type RenamedSig = Sig Name type RenamedSpecInstSig = SpecInstSig Name type RenamedStmt = Stmt Fake Fake Name RenamedPat diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 8b804f279b..3024b8e6b3 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -10,8 +10,8 @@ module RnIfaces ( getInterfaceExports, getImportedInstDecls, getSpecialInstModules, - getDecl, getWiredInDecl, - getImportVersions, + importDecl, recordSlurp, + getImportVersions, checkUpToDate, @@ -22,26 +22,27 @@ module RnIfaces ( IMP_Ubiq() --- import CmdLineOpts ( opt_HiSuffix ) -import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), - HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..), - FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo +import CmdLineOpts ( opt_HiSuffix, opt_HiSuffixPrelude ) +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), HsType(..), + HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), BangType, IfaceSig(..), + FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo, + IE(..) ) import HsPragmas ( noGenPragmas ) import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), RdrName, rdrNameOcc ) -import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availNames ) +import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availName, availNames, addAvailToNameSet ) import RnSource ( rnHsType ) import RnMonad import ParseIface ( parseIface ) import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) -import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList ) +import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addToFM_C, addListToFM, fmToList ) import Name ( Name {-instance NamedThing-}, Provenance, OccName(..), modAndOcc, occNameString, moduleString, pprModule, NameSet(..), emptyNameSet, unionNameSets, nameSetToList, - minusNameSet, mkNameSet, + minusNameSet, mkNameSet, elemNameSet, isWiredInName, maybeWiredInTyConName, maybeWiredInIdName ) import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon ) @@ -49,13 +50,15 @@ import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) import Type ( namesOfType ) import TyVar ( GenTyVar ) import SrcLoc ( mkIfaceSrcLoc ) -import PrelMods ( gHC__ ) +import PrelMods ( gHC__, isPreludeModule ) import Bag import Maybes ( MaybeErr(..), expectJust, maybeToBool ) import ListSetOps ( unionLists ) import Pretty import PprStyle ( PprStyle(..) ) -import Util ( pprPanic ) +import Util ( pprPanic, pprTrace ) +import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer ) + \end{code} @@ -71,10 +74,10 @@ loadInterface :: Pretty -> Module -> RnMG Ifaces loadInterface doc_str load_mod = getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces + Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts inst_mods = ifaces in -- CHECK WHETHER WE HAVE IT ALREADY - if maybeToBool (lookupFM export_env_map load_mod) + if maybeToBool (lookupFM export_envs load_mod) then returnRn ifaces -- Already in the cache; don't re-read it else @@ -86,21 +89,21 @@ loadInterface doc_str load_mod Nothing -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again let - new_export_env_map = addToFM export_env_map load_mod ([],[]) - new_ifaces = Ifaces this_mod mod_vers_map - new_export_env_map - vers_map decls_map inst_map inst_mods + new_export_envs = addToFM export_envs load_mod ([],[]) + new_ifaces = Ifaces this_mod mod_vers_map + new_export_envs + decls all_names imp_names insts inst_mods in setIfacesRn new_ifaces `thenRn_` failWithRn new_ifaces (noIfaceErr load_mod) ; -- Found and parsed! - Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) -> + Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) -> -- LOAD IT INTO Ifaces - mapRn loadExport exports `thenRn` \ avails_s -> - foldlRn (loadDecl load_mod) (decls_map,vers_map) decls `thenRn` \ (new_decls_map, new_vers_map) -> - foldlRn (loadInstDecl load_mod) inst_map insts `thenRn` \ new_insts_map -> + mapRn loadExport exports `thenRn` \ avails_s -> + foldlRn (loadDecl load_mod) decls rd_decls `thenRn` \ new_decls -> + foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts -> let export_env = (concat avails_s, fixs) @@ -109,10 +112,10 @@ loadInterface doc_str load_mod new_ifaces = Ifaces this_mod (addToFM mod_vers_map load_mod mod_vers) - (addToFM export_env_map load_mod export_env) - new_vers_map - new_decls_map - new_insts_map + (addToFM export_envs load_mod export_env) + new_decls + all_names imp_names + new_insts new_inst_mods in setIfacesRn new_ifaces `thenRn_` @@ -125,44 +128,57 @@ loadExport (mod, entities) where new_name occ = newGlobalName mod occ +-- The communcation between this little code fragment and the "entity" rule +-- in ParseIface.y is a bit gruesome. The idea is that things which are +-- destined to be AvailTCs show up as (occ, [non-empty-list]), whereas +-- things destined to be Avails show up as (occ, []) + load_entity (occ, occs) = new_name occ `thenRn` \ name -> - mapRn new_name occs `thenRn` \ names -> - returnRn (Avail name names) - -loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap -loadVersion mod vers_map (occ, version) - = newGlobalName mod occ `thenRn` \ name -> - returnRn (addToFM vers_map name version) - + if null occs then + returnRn (Avail name) + else + mapRn new_name occs `thenRn` \ names -> + returnRn (AvailTC name names) -loadDecl :: Module -> (DeclsMap, VersionMap) +loadDecl :: Module -> DeclsMap -> (Version, RdrNameHsDecl) - -> RnMG (DeclsMap, VersionMap) -loadDecl mod (decls_map, vers_map) (version, decl) - = getDeclBinders new_implicit_name decl `thenRn` \ avail@(Avail name _) -> + -> RnMG DeclsMap +loadDecl mod decls_map (version, decl) + = getDeclBinders new_implicit_name decl `thenRn` \ avail -> returnRn (addListToFM decls_map - [(name,(avail,decl)) | name <- availNames avail], - addToFM vers_map name version + [(name,(version,avail,decl)) | name <- availNames avail] ) where new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name) -loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst) +loadInstDecl :: Module + -> Bag IfaceInst + -> RdrNameInstDecl + -> RnMG (Bag IfaceInst) loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) - = initRnMS emptyRnEnv mod_name InterfaceMode $ - - -- Find out what type constructors and classes are mentioned in the - -- instance declaration. We have to be a bit clever. + = + -- Find out what type constructors and classes are "gates" for the + -- instance declaration. If all these "gates" are slurped in then + -- we should slurp the instance decl too. + -- + -- We *don't* want to count names in the context part as gates, though. + -- For example: + -- instance Foo a => Baz (T a) where ... -- - -- We want to rename the type so that we can find what - -- (free) type constructors are inside it. But we must *not* thereby - -- put new occurrences into the global pool because otherwise we'll force - -- them all to be loaded. We kill two birds with ones stone by renaming - -- with a fresh occurrence pool. - findOccurrencesRn (rnHsType inst_ty) `thenRn` \ ty_names -> - - returnRn ((ty_names, mod_name, decl) `consBag` insts) + -- Here the gates are Baz and T, but *not* Foo. + let + munged_inst_ty = case inst_ty of + HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty + HsPreForAllTy cxt ty -> HsPreForAllTy [] ty + other -> inst_ty + in + -- We find the gates by renaming the instance type with in a + -- and returning the occurrence pool. + initRnMS emptyRnEnv mod_name InterfaceMode ( + findOccurrencesRn (rnHsType munged_inst_ty) + ) `thenRn` \ gate_names -> + returnRn (((mod_name, decl), gate_names) `consBag` insts) \end{code} @@ -177,8 +193,9 @@ checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile checkUpToDate mod_name = findAndReadIface doc_str mod_name `thenRn` \ read_result -> case read_result of - Nothing -> -- Old interface file not found, so we'd better bale out - traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name]) `thenRn_` + Nothing -> -- Old interface file not found, so we'd better bail out + traceRn (ppSep [ppPStr SLIT("Didnt find old iface"), + pprModule PprDebug mod_name]) `thenRn_` returnRn False Just (ParsedIface _ _ usages _ _ _ _ _) @@ -186,7 +203,7 @@ checkUpToDate mod_name checkModUsage usages where -- Only look in current directory, with suffix .hi - doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name] + doc_str = ppSep [ppPStr SLIT("Need usage info from"), pprModule PprDebug mod_name] checkModUsage [] = returnRn True -- Yes! Everything is up to date! @@ -194,52 +211,54 @@ checkModUsage [] = returnRn True -- Yes! Everything is up to date! checkModUsage ((mod, old_mod_vers, old_local_vers) : rest) = loadInterface doc_str mod `thenRn` \ ifaces -> let - Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces - maybe_new_mod_vers = lookupFM mod_vers_map mod + Ifaces _ mod_vers _ decls _ _ _ _ = ifaces + maybe_new_mod_vers = lookupFM mod_vers mod Just new_mod_vers = maybe_new_mod_vers in -- If we can't find a version number for the old module then - -- bale out saying things aren't up to date + -- bail out saying things aren't up to date if not (maybeToBool maybe_new_mod_vers) then returnRn False else -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then - traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod]) `thenRn_` + traceRn (ppSep [ppPStr SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_` checkModUsage rest else - traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod]) `thenRn_` + traceRn (ppSep [ppPStr SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_` -- New module version, so check entities inside - checkEntityUsage mod new_vers_map old_local_vers `thenRn` \ up_to_date -> + checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date -> if up_to_date then - traceRn (ppStr "...but the bits I use havn't.") `thenRn_` + traceRn (ppPStr SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else returnRn False -- This one failed, so just bail out now where - doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod] + doc_str = ppSep [ppPStr SLIT("need version info for"), pprModule PprDebug mod] -checkEntityUsage mod new_vers_map [] +checkEntityUsage mod decls [] = returnRn True -- Yes! All up to date! -checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest) +checkEntityUsage mod decls ((occ_name,old_vers) : rest) = newGlobalName mod occ_name `thenRn` \ name -> - case lookupFM new_vers_map name of + case lookupFM decls name of Nothing -> -- We used it before, but it ain't there now - traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name]) `thenRn_` + traceRn (ppSep [ppPStr SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_` returnRn False - Just new_vers -> -- It's there, but is it up to date? - if new_vers == old_vers then - -- Up to date, so check the rest - checkEntityUsage mod new_vers_map rest - else - traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name]) `thenRn_` - returnRn False -- Out of date, so bale out + Just (new_vers,_,_) -- It's there, but is it up to date? + | new_vers == old_vers + -- Up to date, so check the rest + -> checkEntityUsage mod decls rest + + | otherwise + -- Out of date, so bale out + -> traceRn (ppSep [ppPStr SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_` + returnRn False \end{code} @@ -250,24 +269,56 @@ checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl) -getDecl name - = traceRn doc_str `thenRn_` - loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ _ decls_map _ _) -> - case lookupFM decls_map name of +importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) + -- Returns Nothing for a wired-in or already-slurped decl + +importDecl name necessity + = checkSlurped name `thenRn` \ already_slurped -> + if already_slurped then + returnRn Nothing -- Already dealt with + else + if isWiredInName name then + getWiredInDecl name + else + getIfacesRn `thenRn` \ ifaces -> + let + Ifaces this_mod _ _ _ _ _ _ _ = ifaces + (mod,_) = modAndOcc name + in + if mod == this_mod then -- Don't bring in decls from + pprTrace "importDecl wierdness:" (ppr PprDebug name) $ + returnRn Nothing -- the renamed module's own interface file + -- + else + getNonWiredInDecl name necessity - Just avail_w_decl -> returnRn avail_w_decl +\end{code} - Nothing -> -- Can happen legitimately for "Optional" occurrences - returnRn (NotAvailable, ValD EmptyBinds) +\begin{code} +getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) +getNonWiredInDecl name necessity + = traceRn doc_str `thenRn_` + loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _) -> + case lookupFM decls name of + + Just (version,avail,decl) -> recordSlurp (Just version) avail `thenRn_` + returnRn (Just decl) + + Nothing -> -- Can happen legitimately for "Optional" occurrences + case necessity of { + Optional -> addWarnRn (getDeclWarn name); + other -> addErrRn (getDeclErr name) + } `thenRn_` + returnRn Nothing where + doc_str = ppSep [ppPStr SLIT("Need decl for"), ppr PprDebug name] (mod,_) = modAndOcc name - doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name] \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. It behaves exactly as if the wired in decl were actually in an interface file. Specifically, + * if the wired-in name is a data type constructor or a data constructor, it brings in the type constructor and all the data constructors; and marks as "occurrences" any free vars of the data con. @@ -284,7 +335,6 @@ All this is necessary so that we know all types that are "in play", so that we know just what instances to bring into scope. \begin{code} -getWiredInDecl :: Name -> RnMG AvailInfo getWiredInDecl name = -- Force in the home module in case it has instance decls for -- the thing we are interested in @@ -300,17 +350,13 @@ getWiredInDecl name else loadInterface doc_str mod `thenRn_` returnRn () - ) `thenRn_` - - if is_tycon then - get_wired_tycon the_tycon - else -- Must be a wired-in-Id - if (isDataCon the_id) then -- ... a wired-in data constructor - get_wired_tycon (dataConTyCon the_id) - else -- ... a wired-in non data-constructor - get_wired_id the_id + ) `thenRn_` + + get_wired `thenRn` \ avail -> + recordSlurp Nothing avail `thenRn_` + returnRn Nothing -- No declaration to process further where - doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name] + doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name] (mod,_) = modAndOcc name maybe_wired_in_tycon = maybeWiredInTyConName name is_tycon = maybeToBool maybe_wired_in_tycon @@ -318,16 +364,27 @@ getWiredInDecl name Just the_tycon = maybe_wired_in_tycon Just the_id = maybe_wired_in_id + get_wired | is_tycon -- ... a type constructor + = get_wired_tycon the_tycon + -- Else, must be a wired-in-Id + + | (isDataCon the_id) -- ... a wired-in data constructor + = get_wired_tycon (dataConTyCon the_id) + + | otherwise -- ... a wired-in non data-constructor + = get_wired_id the_id + + get_wired_id id = addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_` - returnRn (Avail (getName id) []) + returnRn (Avail (getName id)) where - id_mentioned = namesOfType (idType id) + id_mentioned = namesOfType (idType id) get_wired_tycon tycon | isSynTyCon tycon = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` - returnRn (Avail (getName tycon) []) + returnRn (Avail (getName tycon)) where (tyvars,ty) = getSynTyConDefn tycon mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars) @@ -335,13 +392,38 @@ get_wired_tycon tycon get_wired_tycon tycon | otherwise -- data or newtype = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` - returnRn (Avail (getName tycon) (map getName data_cons)) + returnRn (AvailTC tycon_name (tycon_name : map getName data_cons)) where - data_cons = tyConDataCons tycon - mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons + tycon_name = getName tycon + data_cons = tyConDataCons tycon + mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons \end{code} +\begin{code} +checkSlurped name + = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _) -> + returnRn (name `elemNameSet` slurped_names) + +recordSlurp maybe_version avail + = getIfacesRn `thenRn` \ ifaces -> + let + Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces + new_slurped_names = addAvailToNameSet slurped_names avail + + new_imp_names = case maybe_version of + Just version -> (availName avail, version) : imp_names + Nothing -> imp_names + + new_ifaces = Ifaces this_mod mod_vers export_envs decls + new_slurped_names + new_imp_names + insts + inst_mods + in + setIfacesRn new_ifaces +\end{code} + %********************************************************* %* * \subsection{Getting other stuff} @@ -351,7 +433,7 @@ get_wired_tycon tycon \begin{code} getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)]) getInterfaceExports mod - = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _) -> + = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _) -> case lookupFM export_envs mod of Nothing -> -- Not there; it must be that the interface file wasn't found; -- the error will have been reported already. @@ -361,66 +443,133 @@ getInterfaceExports mod Just stuff -> returnRn stuff where - doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"] + doc_str = ppSep [pprModule PprDebug mod, ppPStr SLIT("is directly imported")] -getImportedInstDecls :: RnMG [IfaceInst] +getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)] getImportedInstDecls = -- First load any special-instance modules that aren't aready loaded getSpecialInstModules `thenRn` \ inst_mods -> mapRn load_it inst_mods `thenRn_` -- Now we're ready to grab the instance declarations - getIfacesRn `thenRn` \ ifaces -> + -- Find the un-gated ones and return them, + -- removing them from the bag kept in Ifaces + getIfacesRn `thenRn` \ ifaces -> let - Ifaces _ _ _ _ _ insts _ = ifaces + Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces + + -- An instance decl is ungated if all its gates have been slurped + select_ungated :: IfaceInst -- A gated inst decl + + -> ([(Module, RdrNameInstDecl)], [IfaceInst]) -- Accumulator + + -> ([(Module, RdrNameInstDecl)], -- The ungated ones + [IfaceInst]) -- Still gated, but with + -- depeleted gates + select_ungated (decl,gates) (ungated_decls, gated_decls) + | null remaining_gates + = (decl : ungated_decls, gated_decls) + | otherwise + = (ungated_decls, (decl, remaining_gates) : gated_decls) + where + remaining_gates = filter (not . (`elemNameSet` slurped_names)) gates + + (un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts + + new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names + (listToBag still_gated_insts) + inst_mods in - returnRn (bagToList insts) + setIfacesRn new_ifaces `thenRn_` + returnRn un_gated_insts where load_it mod = loadInterface (doc_str mod) mod - doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"] + doc_str mod = ppSep [pprModule PprDebug mod, ppPStr SLIT("is a special-instance module")] + getSpecialInstModules :: RnMG [Module] getSpecialInstModules = getIfacesRn `thenRn` \ ifaces -> let - Ifaces _ _ _ _ _ _ inst_mods = ifaces + Ifaces _ _ _ _ _ _ _ inst_mods = ifaces in returnRn inst_mods \end{code} +getImportVersions figures out what the "usage information" for this moudule is; +that is, what it must record in its interface file as the things it uses. +It records: + - anything reachable from its body code + - any module exported with a "module Foo". + +Why the latter? Because if Foo changes then this module's export list +will change, so we must recompile this module at least as far as +making a new interface file --- but in practice that means complete +recompilation. + +What about this? + module A( f, g ) where module B( f ) where + import B( f ) f = h 3 + g = ... h = ... + +Should we record B.f in A's usages? In fact we don't. Certainly, if +anything about B.f changes than anyone who imports A should be recompiled; +they'll get an early exit if they don't use B.f. However, even if B.f +doesn't change at all, B.h may do so, and this change may not be reflected +in f's version number. So there are two things going on when compiling module A: + +1. Are A.o and A.hi correct? Then we can bale out early. +2. Should modules that import A be recompiled? + +For (1) it is slightly harmful to record B.f in A's usages, because a change in +B.f's version will provoke full recompilation of A, producing an identical A.o, +and A.hi differing only in its usage-version of B.f (which isn't used by any importer). + +For (2), because of the tricky B.h question above, we ensure that A.hi is touched +(even if identical to its previous version) if A's recompilation was triggered by +an imported .hi file date change. Given that, there's no need to record B.f in +A's usages. + +On the other hand, if A exports "module B" then we *do* count module B among +A's usages, because we must recompile A to ensure that A.hi changes appropriately. + \begin{code} -getImportVersions :: [AvailInfo] -- Imported avails +getImportVersions :: Module -- Name of this module + -> Maybe [IE any] -- Export list for this module -> RnMG (VersionInfo Name) -- Version info for these names -getImportVersions imported_avails +getImportVersions this_mod exports = getIfacesRn `thenRn` \ ifaces -> let - Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces - - -- import_versions is harder: we have to group together all the things imported - -- from a particular module. We do this with yet another finite map - - mv_map :: FiniteMap Module [LocalVersion Name] - mv_map = foldl add_mv emptyFM imported_avails - add_mv mv_map (Avail name _) - | isWiredInName name = mv_map -- Don't record versions for wired-in names - | otherwise = case lookupFM mv_map mod of - Just versions -> addToFM mv_map mod ((name,version):versions) - Nothing -> addToFM mv_map mod [(name,version)] - where - (mod,_) = modAndOcc name - version = case lookupFM version_map name of - Just v -> v - Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name) - - import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions) - | (mod, local_versions) <- fmToList mv_map - ] - - -- Question: should we filter the builtins out of import_versions? + Ifaces _ mod_versions_map _ _ _ imp_names _ _ = ifaces + mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod) + + -- mv_map groups together all the things imported from a particular module. + mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name] + + mv_map_mod = foldl add_mod emptyFM export_mods + -- mv_map_mod records all the modules that have a "module M" + -- in this module's export list + + mv_map = foldl add_mv mv_map_mod imp_names + -- mv_map adds the version numbers of things exported individually in - returnRn import_versions + returnRn [ (mod, mod_version mod, local_versions) + | (mod, local_versions) <- fmToList mv_map + ] + + where + export_mods = case exports of + Nothing -> [] + Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod] + + add_mv mv_map v@(name, version) + = addToFM_C (\ ls _ -> (v:ls)) mv_map mod [v] + where + (mod,_) = modAndOcc name + + add_mod mv_map mod = addToFM mv_map mod [] \end{code} %********************************************************* @@ -444,25 +593,25 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> getConFieldNames new_name condecls `thenRn` \ sub_names -> - returnRn (Avail tycon_name sub_names) + returnRn (AvailTC tycon_name (tycon_name : sub_names)) getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> new_name con src_loc `thenRn` \ con_name -> - returnRn (Avail tycon_name [con_name]) + returnRn (AvailTC tycon_name [tycon_name, con_name]) getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> - returnRn (Avail tycon_name []) + returnRn (Avail tycon_name) getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names -> - returnRn (Avail class_name sub_names) + returnRn (AvailTC class_name (class_name : sub_names)) getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) = new_name var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name []) + returnRn (Avail var_name) getDeclBinders new_name (DefD _) = returnRn NotAvailable getDeclBinders new_name (InstD _) = returnRn NotAvailable @@ -511,21 +660,28 @@ findAndReadIface doc_str mod getSearchPathRn `thenRn` \ dirs -> try dirs dirs where - trace_msg = ppHang (ppBesides [ppStr "Reading interface for ", + trace_msg = ppHang (ppBesides [ppPStr SLIT("Reading interface for "), pprModule PprDebug mod, ppSemi]) - 4 (ppBesides [ppStr "reason: ", doc_str]) + 4 (ppBesides [ppPStr SLIT("reason: "), doc_str]) - try all_dirs [] = traceRn (ppStr "...failed") `thenRn_` + mod_str = moduleString mod + hisuf = + if isPreludeModule mod then + case opt_HiSuffixPrelude of { Just hisuf -> hisuf; _ -> ".hi"} + else + case opt_HiSuffix of {Just hisuf -> hisuf; _ -> ".hi"} + + try all_dirs [] = traceRn (ppPStr SLIT("...failed")) `thenRn_` returnRn Nothing try all_dirs (dir:dirs) = readIface file_path `thenRn` \ read_result -> case read_result of Nothing -> try all_dirs dirs - Just iface -> traceRn (ppStr "...done") `thenRn_` + Just iface -> traceRn (ppPStr SLIT("...done")) `thenRn_` returnRn (Just iface) where - file_path = dir ++ "/" ++ moduleString mod ++ ".hi" + file_path = dir ++ "/" ++ moduleString mod ++ hisuf \end{code} @readIface@ trys just one file. @@ -535,11 +691,14 @@ readIface :: String -> RnMG (Maybe ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed readIface file_path - = ioToRnMG (readFile file_path) `thenRn` \ read_result -> + = ioToRnMG (hGetStringBuffer file_path) `thenRn` \ read_result -> +--OLD: = ioToRnMG (readFile file_path) `thenRn` \ read_result -> case read_result of Right contents -> case parseIface contents of - Failed err -> failWithRn Nothing err - Succeeded iface -> returnRn (Just iface) + Failed err -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ -> + failWithRn Nothing err + Succeeded iface -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ -> + returnRn (Just iface) Left (NoSuchThing _) -> returnRn Nothing @@ -573,9 +732,15 @@ mkSearchPath (Just s) \begin{code} noIfaceErr mod sty - = ppBesides [ppStr "Could not find valid interface file for ", ppQuote (pprModule sty mod)] + = ppBesides [ppPStr SLIT("Could not find valid interface file for "), ppQuote (pprModule sty mod)] -- , ppStr " in"]) 4 (ppAboves (map ppStr dirs)) cannaeReadFile file err sty - = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)] + = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppPStr SLIT("; error="), ppStr (show err)] + +getDeclErr name sty + = ppSep [ppPStr SLIT("Failed to find interface decl for"), ppr sty name] + +getDeclWarn name sty + = ppSep [ppPStr SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 62f789de81..5d29108b73 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997 % \section[RnMonad]{The monad used by the renamer} @@ -7,24 +7,36 @@ #include "HsVersions.h" module RnMonad( - RnMonad.., - SST_R + EXP_MODULE(RnMonad), + -- close it up (partly done to allow unfoldings) + EXP_MODULE(SST), + SYN_IE(Module), + FiniteMap, + Bag, + Name, + SYN_IE(RdrNameHsDecl), + SYN_IE(RdrNameInstDecl), + SYN_IE(Version), + SYN_IE(NameSet), + OccName, + Fixity ) where IMP_Ubiq(){-uitous-} import SST -import PreludeGlaST ( SYN_IE(ST), thenST, returnST ) +import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST ) import HsSyn import RdrHsSyn import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning) ) -import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), +import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet, + isLocallyDefinedName, modAndOcc, NamedThing(..) ) -import CmdLineOpts ( opt_D_show_rn_trace ) +import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas ) import PrelInfo ( builtinNames ) import TyCon ( TyCon {- instance NamedThing -} ) import TysWiredIn ( boolTyCon ) @@ -58,8 +70,8 @@ infixr 9 `thenRn`, `thenRn_` \begin{code} sstToIO :: SST REAL_WORLD r -> IO r sstToIO sst - = sstToST sst `thenST` \ r -> - returnST (Right r) + = sstToST sst `thenStrictlyST` \ r -> + returnStrictlyST (Right r) ioToRnMG :: IO r -> RnMG (Either IOError13 r) ioToRnMG io rn_down g_down = stToSST io @@ -106,7 +118,9 @@ data GDown = GDown -- For renaming source code data SDown s = SDown - RnEnv + RnEnv -- Global envt + NameEnv -- Local name envt (includes global name envt, + -- but may shadow it) Module RnSMode @@ -152,7 +166,12 @@ type Fixities = [(OccName, (Fixity, Provenance))] type ModuleAvails = FiniteMap Module Avails -data AvailInfo = NotAvailable | Avail Name [Name] +data AvailInfo = NotAvailable + | Avail Name -- An ordinary identifier + | AvailTC Name -- The name of the type or class + [Name] -- The available pieces of type/class. NB: If the type or + -- class is itself to be in scope, it must be in this list. + -- Thus, typically: Avail Eq [Eq, ==, /=] \end{code} =================================================== @@ -187,16 +206,27 @@ data Ifaces = Ifaces Module -- Name of this module (FiniteMap Module Version) (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports - VersionMap DeclsMap - (Bag IfaceInst) + + NameSet -- All the names (whether "big" or "small", whether wired-in or not, + -- whether locally defined or not) that have been slurped in so far. + + [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that + -- have been slurped in so far, with their versions. Subset of + -- the previous field. This is used to generate the "usage" information + -- for this module. + + (Bag IfaceInst) -- Un-slurped instance decls; this bag is depleted when we + -- slurp an instance decl so that we don't slurp the same one twice. + [Module] -- Set of modules with "special" instance declarations -- Excludes this module -type DeclsMap = FiniteMap Name (AvailInfo, RdrNameHsDecl) -type VersionMap = FiniteMap Name Version -type IfaceInst = ([Name], Module, RdrNameInstDecl) -- The Names are those tycons and - -- classes mentioned by the instance type +type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl) +type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl + [Name]) -- "Gate" names. Slurp this instance decl when this + -- list becomes empty. It's depleted whenever we + -- slurp another type or class decl. \end{code} @@ -230,15 +260,15 @@ initRn mod us dirs loc do_rn initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r -initRnMS env mod_name mode m rn_down g_down +initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down = let - s_down = SDown env mod_name mode + s_down = SDown rn_env name_env mod_name mode in m rn_down s_down emptyIfaces :: Module -> Ifaces -emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag [] +emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag [] builtins :: FiniteMap (Module,OccName) Name builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) @@ -280,7 +310,7 @@ renameSourceCode mod_name name_supply m newMutVarSST [] `thenSST` \ occs_var -> let rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var - s_down = SDown emptyRnEnv mod_name InterfaceMode + s_down = SDown emptyRnEnv emptyNameEnv mod_name InterfaceMode in m rn_down s_down `thenSST` \ result -> @@ -417,20 +447,40 @@ getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down setNameSupplyRn :: RnNameSupply -> RnM s d () setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down = writeMutVarSST names_var names' + +-- The "instance-decl unique supply", inst, is just an integer that's used to +-- give a unique number for each instance declaration. +newInstUniq :: RnM s d Int +newInstUniq (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST names_var `thenSST` \ (us, inst, cache) -> + writeMutVarSST names_var (us, inst+1, cache) `thenSST_` + returnSST inst \end{code} ================ Occurrences ===================== \begin{code} -addOccurrenceName :: Necessity -> Name -> RnM s d () +addOccurrenceName :: Necessity -> Name -> RnM s d Name -- Same name returned as passed addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down + | isLocallyDefinedName name || + not_necessary necessity + = returnSST name + + | otherwise = readMutVarSST occs_var `thenSST` \ occs -> - writeMutVarSST occs_var ((name,necessity) : occs) +-- pprTrace "Add occurrence:" (ppr PprDebug name) $ + writeMutVarSST occs_var ((name,necessity) : occs) `thenSST_` + returnSST name + where + not_necessary Compulsory = False + not_necessary Optional = opt_IgnoreIfacePragmas + -- Never look for optional things if we're + -- ignoring optional input interface information addOccurrenceNames :: Necessity -> [Name] -> RnM s d () addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST occs_var `thenSST` \ occs -> - writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs) + writeMutVarSST occs_var ([(name,necessity) | name <- names, not (isLocallyDefinedName name)] ++ occs) popOccurrenceName :: RnM s d (Maybe (Name,Necessity)) popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down @@ -464,34 +514,34 @@ findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down ================ RnEnv ===================== \begin{code} +getGlobalNameEnv :: RnMS s NameEnv +getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = returnSST global_env + getNameEnv :: RnMS s NameEnv -getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode) - = returnSST name_env +getNameEnv rn_down (SDown rn_env local_env mod_name mode) + = returnSST local_env setNameEnv :: NameEnv -> RnMS s a -> RnMS s a -setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode) - = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode) +setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode) + = m rn_down (SDown rn_env local_env' mod_name mode) getFixityEnv :: RnMS s FixityEnv -getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode) +getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode) = returnSST fixity_env - -setRnEnv :: RnEnv -> RnMS s a -> RnMS s a -setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode) - = m rn_down (SDown rn_env' mod_name mode) \end{code} ================ Module and Mode ===================== \begin{code} getModuleRn :: RnMS s Module -getModuleRn rn_down (SDown rn_env mod_name mode) +getModuleRn rn_down (SDown rn_env local_env mod_name mode) = returnSST mod_name \end{code} \begin{code} getModeRn :: RnMS s RnSMode -getModeRn rn_down (SDown rn_env mod_name mode) +getModeRn rn_down (SDown rn_env local_env mod_name mode) = returnSST mode \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 754dfd29b0..276cf5a40a 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -20,10 +20,10 @@ import HsBinds ( collectTopBinders ) import HsImpExp ( ieName ) import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl), - rdrNameOcc + rdrNameOcc, ieOcc ) import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) -import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate ) +import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate, recordSlurp ) import RnEnv import RnMonad import FiniteMap @@ -83,6 +83,9 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) exportsFromAvail this_mod exports all_avails rn_env `thenRn` \ (export_fn, export_env) -> + -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE + mapRn (recordSlurp Nothing) local_avails `thenRn_` + returnRn (export_fn, Just (export_env, rn_env, local_avails)) ) `thenRn` \ (_, result) -> returnRn result @@ -136,9 +139,7 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc) getInterfaceExports mod `thenRn` \ (avails, fixities) -> filterImports mod import_spec avails `thenRn` \ filtered_avails -> let - filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns) - | Avail n ns <- filtered_avails - ] + filtered_avails' = map set_avail_prov filtered_avails fixities' = [ (occ,(fixity,provenance)) | (occ,fixity) <- fixities ] in qualifyImports mod @@ -147,6 +148,9 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc) as_mod (ExportEnv filtered_avails' fixities') where + set_avail_prov NotAvailable = NotAvailable + set_avail_prov (Avail n) = Avail (set_name_prov n) + set_avail_prov (AvailTC n ns) = AvailTC (set_name_prov n) (map set_name_prov ns) set_name_prov name = setNameProvenance name provenance provenance = Imported mod loc \end{code} @@ -171,11 +175,13 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) getLocalDeclBinders avails decl = getDeclBinders newLocalName decl `thenRn` \ avail -> - returnRn (avail : avails) + case avail of + NotAvailable -> returnRn avails -- Instance decls and suchlike + other -> returnRn (avail : avails) do_one (rdr_name, loc) = newLocalName rdr_name loc `thenRn` \ name -> - returnRn (Avail name []) + returnRn (Avail name) \end{code} %************************************************************************ @@ -199,47 +205,36 @@ filterImports mod Nothing imports = returnRn imports filterImports mod (Just (want_hiding, import_items)) avails - = -- Check that each import item mentions things that are actually available - mapRn check_import_item import_items `thenRn_` - - -- Return filtered environment; no need to filter fixities - returnRn (map new_avail avails) - + = foldlRn (filter_item want_hiding) initial_avails import_items where - import_fm :: FiniteMap OccName RdrNameIE - import_fm = listToFM [(ieOcc ie, ie) | ie <- import_items] - - avail_fm :: FiniteMap OccName AvailInfo - avail_fm = listToFM [(nameOccName name, avail) | avail@(Avail name ns) <- avails] - - new_avail NotAvailable = NotAvailable - new_avail avail@(Avail name _) - | not in_import_items && want_hiding = avail - | not in_import_items && not want_hiding = NotAvailable - | in_import_items && want_hiding = NotAvailable - | in_import_items && not want_hiding = filtered_avail - where - maybe_import_item = lookupFM import_fm (nameOccName name) - in_import_items = maybeToBool maybe_import_item - Just import_item = maybe_import_item - filtered_avail = filterAvail import_item avail - - check_import_item :: RdrNameIE -> RnMG () - check_import_item item - = checkRn (maybeToBool maybe_matching_avail && sub_names_ok item avail) - (badImportItemErr mod item) - where - item_name = ieOcc item - maybe_matching_avail = lookupFM avail_fm item_name - Just avail = maybe_matching_avail - - sub_names_ok (IEVar _) _ = True - sub_names_ok (IEThingAbs _) _ = True - sub_names_ok (IEThingAll _) _ = True - sub_names_ok (IEThingWith _ wanted) (Avail _ has) = all ((`elem` has_list) . rdrNameOcc) wanted - where - has_list = map nameOccName has - sub_names_ok other1 other2 = False + initial_avails | want_hiding = avails + | otherwise = [] + + import_fm :: FiniteMap OccName AvailInfo + import_fm = listToFM [ (nameOccName name, avail) + | avail <- avails, + name <- availEntityNames avail] + + filter_item want_hiding avails_so_far item@(IEModuleContents _) + = addErrRn (badImportItemErr mod item) `thenRn_` + returnRn avails_so_far + + filter_item want_hiding avails_so_far item + | not (maybeToBool maybe_in_import_avails) || + (case filtered_avail of { NotAvailable -> True; other -> False }) + = addErrRn (badImportItemErr mod item) `thenRn_` + returnRn avails_so_far + + | want_hiding = returnRn (foldr hide_it [] avails_so_far) + | otherwise = returnRn (filtered_avail : avails_so_far) -- Explicit import list + + where + maybe_in_import_avails = lookupFM import_fm (ieOcc item) + Just avail = maybe_in_import_avails + filtered_avail = filterAvail item avail + hide_it avail avails = case hideAvail item avail of + NotAvailable -> avails + avail' -> avail' : avails \end{code} @@ -277,8 +272,7 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) mod_avail_env = unitFM qual_mod avails - add_name name_env NotAvailable = returnRn name_env - add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns) + add_name name_env avail = foldlRn add_one name_env (availNames avail) add_one :: NameEnv -> Name -> RnMG NameEnv add_one env name = add_to_env addOneToNameEnvRn env occ_name name @@ -347,10 +341,9 @@ type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo) emptyAvailEnv = emptyFM unitAvailEnv :: RdrNameIE -> AvailInfo -> AvailEnv -unitAvailEnv ie NotAvailable - = emptyFM -unitAvailEnv ie avail@(Avail n ns) - = unitFM (nameOccName n) (ie,avail) +unitAvailEnv ie NotAvailable = emptyFM +unitAvailEnv ie (AvailTC _ []) = emptyFM +unitAvailEnv ie avail = unitFM (nameOccName (availName avail)) (ie,avail) plusAvailEnv a1 a2 = mapRn (addErrRn.availClashErr) (conflictsFM bad_avail a1 a2) `thenRn_` @@ -360,10 +353,18 @@ listToAvailEnv :: RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv listToAvailEnv ie items = foldlRn plusAvailEnv emptyAvailEnv (map (unitAvailEnv ie) items) -bad_avail (ie1,Avail n1 _) (ie2,Avail n2 _) = n1 /= n2 -- Same OccName, different Name +bad_avail (ie1,avail1) (ie2,avail2) = availName avail1 /= availName avail2 -- Same OccName, different Name plus_avail (ie1,a1) (ie2,a2) = (ie1, a1 `plusAvail` a2) \end{code} +Processing the export list. + +You might think that we should record things that appear in the export list as +``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here) +that they are in scope, but there is no need to slurp in their actual declaration +(which is what addOccurrenceName forces). Indeed, doing so would big trouble when +compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type +includes ConcBase.StateAndSynchVar#, and so on... \begin{code} exportsFromAvail :: Module @@ -389,16 +390,18 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_ where full_avail_env :: UniqFM AvailInfo full_avail_env = addListToUFM_C plusAvail emptyUFM - [(name,avail) | avail@(Avail name _) <- concat (eltsFM all_avails)] - -- NB: full_avail_env won't contain bindings for data constructors and class ops, - -- which is right and proper; attempts to export them on their own will provoke an error + [(name, avail) | avail <- concat (eltsFM all_avails), + name <- availEntityNames avail + ] + + -- NB: full_avail_env will contain bindings for class ops but not constructors + -- (see defn of availEntityNames) exports_from_item :: RdrNameIE -> RnMG AvailEnv exports_from_item ie@(IEModuleContents mod) = case lookupFM all_avails mod of Nothing -> failWithRn emptyAvailEnv (modExportErr mod) - Just avails -> addOccurrenceNames Compulsory [n | Avail n _ <- avails] `thenRn_` - listToAvailEnv ie avails + Just avails -> listToAvailEnv ie avails exports_from_item ie | not (maybeToBool maybe_in_scope) @@ -416,8 +419,7 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_ = failWithRn emptyAvailEnv (exportItemErr ie export_avail) | otherwise -- Phew! It's OK! - = addOccurrenceName Compulsory name `thenRn_` - returnRn (unitAvailEnv ie export_avail) + = returnRn (unitAvailEnv ie export_avail) where maybe_in_scope = lookupNameEnv name_env (ieName ie) Just name = maybe_in_scope @@ -486,24 +488,22 @@ mk_export_fn avails %************************************************************************ \begin{code} -ieOcc ie = rdrNameOcc (ieName ie) - badImportItemErr mod ie sty - = ppSep [ppStr "Module", pprModule sty mod, ppStr "does not export", ppr sty ie] + = ppSep [ppPStr SLIT("Module"), pprModule sty mod, ppPStr SLIT("does not export"), ppr sty ie] modExportErr mod sty - = ppCat [ ppStr "Unknown module in export list: module", ppPStr mod] + = ppCat [ ppPStr SLIT("Unknown module in export list: module"), ppPStr mod] exportItemErr export_item NotAvailable sty - = ppSep [ ppStr "Export item not in scope:", ppr sty export_item ] + = ppSep [ ppPStr SLIT("Export item not in scope:"), ppr sty export_item ] exportItemErr export_item avail sty - = ppHang (ppStr "Export item not fully in scope:") - 4 (ppAboves [ppCat [ppStr "Wanted: ", ppr sty export_item], - ppCat [ppStr "Available: ", ppr sty (ieOcc export_item), pprAvail sty avail]]) + = ppHang (ppPStr SLIT("Export item not fully in scope:")) + 4 (ppAboves [ppCat [ppPStr SLIT("Wanted: "), ppr sty export_item], + ppCat [ppPStr SLIT("Available: "), ppr sty (ieOcc export_item), pprAvail sty avail]]) availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty - = ppHang (ppCat [ppStr "Conflicting exports for local name: ", ppr sty occ_name]) + = ppHang (ppCat [ppPStr SLIT("Conflicting exports for local name: "), ppr sty occ_name]) 4 (ppAboves [ppr sty ie1, ppr sty ie2]) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 588619b2c0..65edce3177 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -21,12 +21,14 @@ import HsCore import CmdLineOpts ( opt_IgnoreIfacePragmas ) import RnBinds ( rnTopBinds, rnMethodBinds ) -import RnEnv ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, - lookupOptionalOccRn, newDfunName, +import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, + lookupOptionalOccRn, newSysName, newDfunName, listType_RDR, tupleType_RDR ) import RnMonad -import Name ( Name, isLocallyDefined, occNameString, +import Name ( Name, isLocallyDefined, + OccName(..), occNameString, prefixOccName, + ExportFlag(..), Provenance, SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet, elemNameSet @@ -84,7 +86,7 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds -> rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ - lookupRn name `thenRn` \ name' -> + lookupBndrRn name `thenRn` \ name' -> rnHsType ty `thenRn` \ ty' -> -- Get the pragma info, unless we should ignore it @@ -118,7 +120,7 @@ checks at the same time. \begin{code} rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc)) = pushSrcLocRn src_loc $ - lookupRn tycon `thenRn` \ tycon' -> + lookupBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn "data declaration" tyvars $ \ tyvars' -> rnContext context `thenRn` \ context' -> mapRn rnConDecl condecls `thenRn` \ condecls' -> @@ -128,7 +130,7 @@ rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc)) rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc)) = pushSrcLocRn src_loc $ - lookupRn tycon `thenRn` \ tycon' -> + lookupBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' -> rnContext context `thenRn` \ context' -> rnConDecl condecl `thenRn` \ condecl' -> @@ -138,7 +140,7 @@ rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc)) rnDecl (TyD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ - lookupRn name `thenRn` \ name' -> + lookupBndrRn name `thenRn` \ name' -> bindTyVarsRn "type declaration" tyvars $ \ tyvars' -> rnHsType ty `thenRn` \ ty' -> returnRn (TyD (TySynonym name' tyvars' ty' src_loc)) @@ -159,15 +161,22 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) = pushSrcLocRn src_loc $ bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] -> rnContext context `thenRn` \ context' -> - lookupRn cname `thenRn` \ cname' -> + lookupBndrRn cname `thenRn` \ cname' -> mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' -> rnMethodBinds mbinds `thenRn` \ mbinds' -> ASSERT(isNoClassPragmas pragmas) returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)) where - rn_op clas clas_tyvar sig@(ClassOpSig op ty pragmas locn) + rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn) = pushSrcLocRn locn $ - lookupRn op `thenRn` \ op_name -> + let + dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op) + in + lookupBndrRn op `thenRn` \ op_name -> + newSysName dm_occ Exported locn `thenRn` \ dm_name -> + addOccurrenceName Optional dm_name `thenRn_` + -- Call up interface info for default method, if such info exists + rnHsType ty `thenRn` \ new_ty -> let (ctxt, op_ty) = case new_ty of @@ -187,8 +196,8 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) (classTyVarInOpCtxtErr clas_tyvar sig) `thenRn_` - ASSERT(isNoClassOpPragmas pragmas) - returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn) +-- ASSERT(isNoClassOpPragmas pragmas) + returnRn (ClassOpSig op_name dm_name new_ty locn) \end{code} @@ -199,42 +208,39 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) %********************************************************* \begin{code} -rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc)) +rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) = pushSrcLocRn src_loc $ - rnHsType inst_ty `thenRn` \ inst_ty' -> - rnMethodBinds mbinds `thenRn` \ mbinds' -> - mapRn rn_uprag uprags `thenRn` \ new_uprags -> - rn_dfun maybe_dfun_name `thenRn` \ dfun_name' -> + rnHsType inst_ty `thenRn` \ inst_ty' -> + rnMethodBinds mbinds `thenRn` \ mbinds' -> + mapRn rn_uprag uprags `thenRn` \ new_uprags -> - returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name' src_loc)) - where - rn_dfun Nothing = newDfunName src_loc `thenRn` \ n' -> - returnRn (Just n') - rn_dfun (Just n) = lookupOccRn n `thenRn` \ n' -> - -- The dfun is not optional, because we use its version number - -- to identify the version of the instance declaration - returnRn (Just n') + newDfunName maybe_dfun src_loc `thenRn` \ dfun_name -> + addOccurrenceName Compulsory dfun_name `thenRn_` + -- The dfun is not optional, because we use its version number + -- to identify the version of the instance declaration + returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc)) + where rn_uprag (SpecSig op ty using locn) = pushSrcLocRn src_loc $ - lookupRn op `thenRn` \ op_name -> + lookupBndrRn op `thenRn` \ op_name -> rnHsType ty `thenRn` \ new_ty -> rn_using using `thenRn` \ new_using -> returnRn (SpecSig op_name new_ty new_using locn) rn_uprag (InlineSig op locn) = pushSrcLocRn locn $ - lookupRn op `thenRn` \ op_name -> + lookupBndrRn op `thenRn` \ op_name -> returnRn (InlineSig op_name locn) rn_uprag (DeforestSig op locn) = pushSrcLocRn locn $ - lookupRn op `thenRn` \ op_name -> + lookupBndrRn op `thenRn` \ op_name -> returnRn (DeforestSig op_name locn) rn_uprag (MagicUnfoldingSig op str locn) = pushSrcLocRn locn $ - lookupRn op `thenRn` \ op_name -> + lookupBndrRn op `thenRn` \ op_name -> returnRn (MagicUnfoldingSig op_name str locn) rn_using Nothing = returnRn Nothing @@ -294,13 +300,13 @@ rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl rnConDecl (ConDecl name tys src_loc) = pushSrcLocRn src_loc $ checkConName name `thenRn_` - lookupRn name `thenRn` \ new_name -> + lookupBndrRn name `thenRn` \ new_name -> mapRn rnBangTy tys `thenRn` \ new_tys -> returnRn (ConDecl new_name new_tys src_loc) rnConDecl (ConOpDecl ty1 op ty2 src_loc) = pushSrcLocRn src_loc $ - lookupRn op `thenRn` \ new_op -> + lookupBndrRn op `thenRn` \ new_op -> rnBangTy ty1 `thenRn` \ new_ty1 -> rnBangTy ty2 `thenRn` \ new_ty2 -> returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc) @@ -308,18 +314,18 @@ rnConDecl (ConOpDecl ty1 op ty2 src_loc) rnConDecl (NewConDecl name ty src_loc) = pushSrcLocRn src_loc $ checkConName name `thenRn_` - lookupRn name `thenRn` \ new_name -> + lookupBndrRn name `thenRn` \ new_name -> rnHsType ty `thenRn` \ new_ty -> returnRn (NewConDecl new_name new_ty src_loc) rnConDecl (RecConDecl name fields src_loc) = pushSrcLocRn src_loc $ - lookupRn name `thenRn` \ new_name -> + lookupBndrRn name `thenRn` \ new_name -> mapRn rnField fields `thenRn` \ new_fields -> returnRn (RecConDecl new_name new_fields src_loc) rnField (names, ty) - = mapRn lookupRn names `thenRn` \ new_names -> + = mapRn lookupBndrRn names `thenRn` \ new_names -> rnBangTy ty `thenRn` \ new_ty -> returnRn (new_names, new_ty) @@ -542,6 +548,10 @@ rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders where names = map (\ (UfValBinder name _) -> name) bndrs tys = map (\ (UfValBinder _ ty) -> ty) bndrs + +rnCoreBndrNamess names thing_inside + = bindLocalsRn "unfolding value" names $ \ names' -> + thing_inside names' \end{code} \begin{code} @@ -555,9 +565,9 @@ rnCoreAlts (UfAlgAlts alts deflt) rnCoreDefault deflt `thenRn` \ deflt' -> returnRn (UfAlgAlts alts' deflt') where - rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' -> - rnCoreBndrs bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenRn` \ rhs' -> + rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' -> + bindLocalsRn "unfolding alt" bndrs $ \ bndrs' -> + rnCoreExpr rhs `thenRn` \ rhs' -> returnRn (con', bndrs', rhs') rnCoreAlts (UfPrimAlts alts deflt) @@ -569,8 +579,8 @@ rnCoreAlts (UfPrimAlts alts deflt) returnRn (lit, rhs') rnCoreDefault UfNoDefault = returnRn UfNoDefault -rnCoreDefault (UfBindDefault bndr rhs) = rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr rhs `thenRn` \ rhs' -> +rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] $ \ [bndr'] -> + rnCoreExpr rhs `thenRn` \ rhs' -> returnRn (UfBindDefault bndr' rhs') rnCoercion (UfIn n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn n') @@ -594,23 +604,27 @@ rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) \begin{code} derivingNonStdClassErr clas sty - = ppCat [ppStr "non-standard class in deriving:", ppr sty clas] + = ppCat [ppPStr SLIT("non-standard class in deriving:"), ppr sty clas] classTyVarNotInOpTyErr clas_tyvar sig sty - = ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"]) + = ppHang (ppBesides [ppPStr SLIT("Class type variable `"), + ppr sty clas_tyvar, + ppPStr SLIT("' does not appear in method signature:")]) 4 (ppr sty sig) classTyVarInOpCtxtErr clas_tyvar sig sty - = ppHang (ppBesides [ ppStr "Class type variable `", ppr sty clas_tyvar, - ppStr "' present in method's local overloading context:"]) + = ppHang (ppBesides [ ppPStr SLIT("Class type variable `"), ppr sty clas_tyvar, + ppPStr SLIT("' present in method's local overloading context:")]) 4 (ppr sty sig) dupClassAssertWarn ctxt dups sty - = ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"]) + = ppHang (ppBesides [ppPStr SLIT("Duplicate class assertion `"), + ppr sty dups, + ppPStr SLIT("' in context:")]) 4 (ppr sty ctxt) badDataCon name sty - = ppCat [ppStr "Illegal data constructor name:", ppr sty name] + = ppCat [ppPStr SLIT("Illegal data constructor name:"), ppr sty name] \end{code} diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index f668ecfa43..0171758a8f 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -159,7 +159,9 @@ addBinderInfo, orBinderInfo addBinderInfo DeadCode info2 = info2 addBinderInfo info1 DeadCode = info1 addBinderInfo info1 info2 - = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) + = case (min (getBinderInfoArity info1) (getBinderInfoArity info2)) of + (I# i#) -> ManyOcc (I# i#) + -- ManyOcc min (getBinderInfoArity info1) (getBinderInfoArity info2)) -- (orBinderInfo orig new) is used when combining occurrence -- info from branches of a case @@ -168,13 +170,26 @@ orBinderInfo DeadCode info2 = info2 orBinderInfo info1 DeadCode = info1 orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) (OneOcc posn2 dup2 scc2 n_alts2 ar_2) - = OneOcc (combine_posns posn1 posn2) - (combine_dups dup1 dup2) - (combine_sccs scc1 scc2) - (n_alts1 + n_alts2) - (min ar_1 ar_2) + = let + -- Seriously maligned in order to make it stricter, + -- let's hope it is worth it.. + posn = combine_posns posn1 posn2 + scc = combine_sccs scc1 scc2 + dup = combine_dups dup1 dup2 + alts = n_alts1 + n_alts2 + ar = min ar_1 ar_2 + + -- No CSE, please! + cont1 = case scc of { InsideSCC -> cont2; _ -> cont2 } + cont2 = case dup of { DupDanger -> cont3; _ -> cont3 } + cont3 = case alts of { (I# 0#) -> cont4; _ -> cont4 } + cont4 = case ar of { (I# 0#) -> cont5; _ -> cont5 } + cont5 = OneOcc posn dup scc alts ar + in + case posn of { FunOcc -> cont1; _ -> cont1 } orBinderInfo info1 info2 - = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) + = case (min (getBinderInfoArity info1) (getBinderInfoArity info2)) of + (I# i#) -> ManyOcc (I# i#) -- (andBinderInfo orig new) is used in two situations: -- First, when a variable whose occurrence info @@ -190,14 +205,27 @@ orBinderInfo info1 info2 andBinderInfo DeadCode info2 = DeadCode andBinderInfo info1 DeadCode = DeadCode -andBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) - (OneOcc posn2 dup2 scc2 n_alts2 ar_2) - = OneOcc (combine_posns posn1 posn2) - (combine_dups dup1 dup2) - (combine_sccs scc1 scc2) - (n_alts1 + n_alts2) - ar_1 -- Min arity just from orig -andBinderInfo info1 info2 = ManyOcc (getBinderInfoArity info1) +andBinderInfo (OneOcc posn1 dup1 scc1 (I# n_alts1#) (I# ar_1#)) + (OneOcc posn2 dup2 scc2 (I# n_alts2#) ar_2) + = let + -- Perversly maligned in order to make it stricter. + posn = combine_posns posn1 posn2 + scc = combine_sccs scc1 scc2 + dup = combine_dups dup1 dup2 + alts = I# (n_alts1# +# n_alts2#) + + -- No CSE, please! + cont1 = case scc of { InsideSCC -> cont2; _ -> cont2 } + cont2 = case dup of { DupDanger -> cont3; _ -> cont3 } + cont3 = case alts of { (I# 0#) -> cont4; _ -> cont4 } + cont4 = OneOcc posn dup scc alts (I# ar_1#) + in + case posn of {FunOcc -> cont1; _ -> cont1} + +andBinderInfo info1 info2 = + case getBinderInfoArity info1 of + (I# i#) -> ManyOcc (I# i#) + --ManyOcc (getBinderInfoArity info1) combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn @@ -225,20 +253,20 @@ getBinderInfoArity (OneOcc _ _ _ _ i) = i \begin{code} instance Outputable BinderInfo where - ppr sty DeadCode = ppStr "Dead" - ppr sty (ManyOcc ar) = ppBesides [ ppStr "Many-", ppInt ar ] + ppr sty DeadCode = ppPStr SLIT("Dead") + ppr sty (ManyOcc ar) = ppBesides [ ppPStr SLIT("Many-"), ppInt ar ] ppr sty (OneOcc posn dup_danger in_scc n_alts ar) - = ppBesides [ ppStr "One-", pp_posn posn, ppChar '-', pp_danger dup_danger, + = ppBesides [ ppPStr SLIT("One-"), pp_posn posn, ppChar '-', pp_danger dup_danger, ppChar '-', pp_scc in_scc, ppChar '-', ppInt n_alts, ppChar '-', ppInt ar ] where - pp_posn FunOcc = ppStr "fun" - pp_posn ArgOcc = ppStr "arg" + pp_posn FunOcc = ppPStr SLIT("fun") + pp_posn ArgOcc = ppPStr SLIT("arg") - pp_danger DupDanger = ppStr "*dup*" - pp_danger NoDupDanger = ppStr "nodup" + pp_danger DupDanger = ppPStr SLIT("*dup*") + pp_danger NoDupDanger = ppPStr SLIT("nodup") - pp_scc InsideSCC = ppStr "*SCC*" - pp_scc NotInsideSCC = ppStr "noscc" + pp_scc InsideSCC = ppPStr SLIT("*SCC*") + pp_scc NotInsideSCC = ppPStr SLIT("noscc") \end{code} diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index b66b6184d9..91b66e6f29 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -24,7 +24,7 @@ import Outputable ( Outputable(..){-instance (,)-} ) import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenTyVar ) -import Pretty ( ppInt, ppStr, ppBesides, ppAboves ) +import Pretty ( ppInt, ppPStr, ppBesides, ppAboves ) import SetLevels -- all of it import TyVar ( GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-} ) @@ -106,9 +106,9 @@ floatOutwards us pgm (tlets, ntlets, lams) = get_stats (sum_stats fss) in pprTrace "FloatOut stats: " (ppBesides [ - ppInt tlets, ppStr " Lets floated to top level; ", - ppInt ntlets, ppStr " Lets floated elsewhere; from ", - ppInt lams, ppStr " Lambda groups"]) + ppInt tlets, ppPStr SLIT(" Lets floated to top level; "), + ppInt ntlets, ppPStr SLIT(" Lets floated elsewhere; from "), + ppInt lams, ppPStr SLIT(" Lambda groups")]) ) concat final_toplev_binds_s }} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 3ed4f73c0a..8d330b9275 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -29,8 +29,8 @@ import Id ( idWantsToBeINLINEd, isConstMethodId, unitIdSet, elementOfIdSet, addOneToIdSet, SYN_IE(IdSet), nullIdEnv, unitIdEnv, combineIdEnvs, - delOneFromIdEnv, delManyFromIdEnv, - mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), + delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, + mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Eq-} ) import Name ( isExported ) @@ -122,20 +122,39 @@ tagBinders :: UsageDetails -- Of scope -> (UsageDetails, -- Details with binders removed [(Id,BinderInfo)]) -- Tagged binders -tagBinders usage binders +tagBinders usage binders = + let + usage' = usage `delManyFromIdEnv` binders + uss = [ (binder, usage_of usage binder) | binder <- binders ] + in + if isNullIdEnv usage' then + (usage', uss) + else + (usage', uss) +{- = (usage `delManyFromIdEnv` binders, [ (binder, usage_of usage binder) | binder <- binders ] ) - +-} tagBinder :: UsageDetails -- Of scope -> Id -- Binders -> (UsageDetails, -- Details with binders removed (Id,BinderInfo)) -- Tagged binders -tagBinder usage binder - = (usage `delOneFromIdEnv` binder, - (binder, usage_of usage binder) - ) +tagBinder usage binder = + let + usage' = usage `delOneFromIdEnv` binder + us = usage_of usage binder + cont = + if isNullIdEnv usage' then -- bogus test to force evaluation. + (usage', (binder, us)) + else + (usage', (binder, us)) + in + case us of { DeadCode -> cont; _ -> cont } + +-- (binder, usage_of usage binder) + usage_of usage binder | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many @@ -436,26 +455,40 @@ occAnal env expr@(Lam (ValBinder binder) body) -- ANDY: WE MUST THINK ABOUT THIS! (ToDo) occAnal env (Lam (TyBinder tyvar) body) - = (mapIdEnv markDangerousToDup body_usage, - Lam (TyBinder tyvar) body') - where - (body_usage, body') = occAnal env body + = case occAnal env body of { (body_usage, body') -> + (mapIdEnv markDangerousToDup body_usage, + Lam (TyBinder tyvar) body') } +-- where +-- (body_usage, body') = occAnal env body occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder" occAnal env (Case scrut alts) - = (scrut_usage `combineUsageDetails` alts_usage, - Case scrut' alts') + = case occAnalAlts env alts of { (alts_usage, alts') -> + case occAnal env scrut of { (scrut_usage, scrut') -> + let + det = scrut_usage `combineUsageDetails` alts_usage + in + if isNullIdEnv det then + (det, Case scrut' alts') + else + (det, Case scrut' alts') }} +{- + (scrut_usage `combineUsageDetails` alts_usage, + Case scrut' alts') where (scrut_usage, scrut') = occAnal env scrut (alts_usage, alts') = occAnalAlts env alts +-} occAnal env (Let bind body) - = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh) + = case occAnal new_env body of { (body_usage, body') -> + case occAnalBind env bind body_usage of { (final_usage, new_binds) -> + (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh) where new_env = env `addNewCands` (bindersOf bind) - (body_usage, body') = occAnal new_env body - (final_usage, new_binds) = occAnalBind env bind body_usage +-- (body_usage, body') = occAnal new_env body +-- (final_usage, new_binds) = occAnalBind env bind body_usage \end{code} Case alternatives diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 2b61266f63..b6935c2013 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -35,7 +35,7 @@ import Id ( idType, mkSysLocal, idSetToList, lookupIdEnv, SYN_IE(IdEnv) ) -import Pretty ( ppStr, ppBesides, ppChar, ppInt ) +import Pretty ( ppPStr, ppBesides, ppChar, ppInt ) import SrcLoc ( noSrcLoc ) import Type ( isPrimType, mkTyVarTys, mkForAllTys ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, @@ -143,7 +143,7 @@ unTopify Top = Level 0 0 unTopify lvl = lvl instance Outputable Level where - ppr sty Top = ppStr "<Top>" + ppr sty Top = ppPStr SLIT("<Top>") ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ] \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index b92e2a7017..787d1688e2 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -55,7 +55,7 @@ import Outputable ( Outputable(..){-instance * (,) -} ) import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) -import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr ) +import Pretty ( ppShow, ppAboves, ppAbove, ppCat ) import SAT ( doStaticArgs ) import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) @@ -98,14 +98,16 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds else return ()) >> -- Do the main business + --case (splitUniqSupply us) of { (us1,us2) -> foldl_mn do_core_pass - (binds, us1, init_specdata, zeroSimplCount) + (binds, us, init_specdata, zeroSimplCount) core_todos - >>= \ (processed_binds, _, spec_data, simpl_stats) -> + >>= \ (processed_binds, us', spec_data, simpl_stats) -> -- Do the final tidy-up let - final_binds = tidyCorePgm module_name us2 processed_binds + final_binds = core_linter "TidyCorePgm" True $ + tidyCorePgm module_name us' processed_binds in -- Report statistics @@ -116,25 +118,28 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds else return ()) >> -- - return (final_binds, spec_data) + return (final_binds, spec_data) --} where - (us1, us2) = splitUniqSupply us +-- (us1, us2) = splitUniqSupply us init_specdata = initSpecData local_tycons tycon_specs ------------- - core_linter what = if opt_DoCoreLinting - then (if opt_D_show_passes then + core_linter what spec_done + = if opt_DoCoreLinting + then (if opt_D_show_passes then trace ("\n*** Core Lint result of " ++ what) - else id - ) - lintCoreBindings ppr_style what - else ( \ spec_done binds -> binds ) + else id + ) + lintCoreBindings ppr_style what spec_done + else id -------------- - do_core_pass info@(binds, us, spec_data, simpl_stats) to_do - = let - (us1, us2) = splitUniqSupply us - in + do_core_pass info@(binds, us, spec_data, simpl_stats) to_do = +-- let +-- (us1, us2) = splitUniqSupply us +-- in + case (splitUniqSupply us) of + (us1,us2) -> case to_do of CoreDoSimplify simpl_sw_chkr -> _scc_ "CoreSimplify" @@ -487,24 +492,24 @@ tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs))) -- Eliminate polymorphic case, for which we can't generate code just yet tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs))) | not (maybeToBool (maybeAppSpecDataTyConExpandingDicts (coreExprType scrut))) - = pprTrace "Warning: discarding polymophic case:" (ppr PprDebug scrut) $ + = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $ case scrut of Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs) other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs) tidyCoreExpr (Case scrut alts) = tidyCoreExpr scrut `thenTM` \ scrut' -> - tidy_alts alts `thenTM` \ alts' -> + tidy_alts scrut' alts `thenTM` \ alts' -> returnTM (Case scrut' alts') where - tidy_alts (AlgAlts alts deflt) + tidy_alts scrut (AlgAlts alts deflt) = mapTM tidy_alg_alt alts `thenTM` \ alts' -> - tidy_deflt deflt `thenTM` \ deflt' -> + tidy_deflt scrut deflt `thenTM` \ deflt' -> returnTM (AlgAlts alts' deflt') - tidy_alts (PrimAlts alts deflt) + tidy_alts scrut (PrimAlts alts deflt) = mapTM tidy_prim_alt alts `thenTM` \ alts' -> - tidy_deflt deflt `thenTM` \ deflt' -> + tidy_deflt scrut deflt `thenTM` \ deflt' -> returnTM (PrimAlts alts' deflt') tidy_alg_alt (con,bndrs,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' -> @@ -521,8 +526,8 @@ tidyCoreExpr (Case scrut alts) -- It's quite easily done: simply extend the environment to bind the -- default binder to the scrutinee. - tidy_deflt NoDefault = returnTM NoDefault - tidy_deflt (BindDefault bndr rhs) + tidy_deflt scrut NoDefault = returnTM NoDefault + tidy_deflt scrut (BindDefault bndr rhs) = extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' -> returnTM (BindDefault bndr rhs') where @@ -610,7 +615,7 @@ litToRep (NoRepInteger i integer_ty) litToRep (NoRepRational r rational_ty) = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg -> tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg -> - returnTM (rational_ty, Con ratio_data_con [num_arg, denom_arg]) + returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg]) where (ratio_data_con, integer_ty) = case (maybeAppDataTyCon rational_ty) of @@ -688,13 +693,22 @@ mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' -> addTopFloat :: Type -> CoreExpr -> TidyM Id addTopFloat lit_ty lit_rhs mod env (us, floats) - = (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs)) + = case splitUniqSupply us of + (us',us1) -> + let + lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc + lit_id = setIdVisibility mod lit_local + --(us', us1) = splitUniqSupply us + uniq = getUnique us1 + in + (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs)) +{- where lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc lit_id = setIdVisibility mod lit_local (us', us1) = splitUniqSupply us uniq = getUnique us1 - +-} lookupTM v mod env usf = case lookupIdEnv env v of Nothing -> (v, usf) diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 5653bfa489..b170ad36e1 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -266,12 +266,18 @@ extendIdEnvWithAtom extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) (in_id,occ_info) atom - = SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps + = case atom of + LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps + VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env + (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps +--SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps where new_in_id_env = addOneToIdEnv in_id_env in_id atom +{- new_out_id_env = case atom of LitArg _ -> out_id_env VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info) +-} extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) @@ -344,13 +350,21 @@ modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo) -> (OutId, BinderInfo, RhsInfo) -> (OutId, BinderInfo, RhsInfo) modifyOutEnvItem (id, occ, info1) (_, _, info2) - = (id, occ, new_info) + = case (info1, info2) of + (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2)) + (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2)) + (_, NoRhsInfo) -> (id,occ, info1) + other -> (id,occ, info2) + +--(id, occ, new_info) +{- where new_info = case (info1, info2) of (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2) (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2) (_, NoRhsInfo) -> info1 other -> info2 +-} \end{code} @@ -411,13 +425,23 @@ extendEnvGivenNewRhs env out_id rhs extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) occ_info out_id rhs - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps + = let + s_env = SimplEnv chkr encl_cc ty_env in_id_env out_id_env new_con_apps + s_env_uf = SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding new_con_apps + in + case guidance of + -- Cheap and nasty hack to force strict insertion. + UnfoldNever -> + if isEmptyFM new_con_apps then s_env else s_env + other -> + if isEmptyFM new_con_apps then s_env_uf else s_env_uf where - new_con_apps = extendConApps con_apps out_id rhs + new_con_apps = extendConApps con_apps out_id rhs +{- new_out_id_env = case guidance of UnfoldNever -> out_id_env -- No new stuff to put in other -> out_id_env_with_unfolding - +-} -- If there is an unfolding, we add rhs-info for out_id, -- *and* modify the occ info for rhs's interesting free variables. -- @@ -512,14 +536,21 @@ which is OK if not clever. \begin{code} extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) (out_id, ((_,occ_info), old_rhs)) - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps + = case (form_summary, guidance) of + (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in + (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps + (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps + other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable + +-- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps where +{- new_out_id_env = case (form_summary, guidance) of (_, UnfoldNever) -> out_id_env -- No new stuff to put in (ValueForm, _) -> out_id_env_with_unfolding (VarForm, _) -> out_id_env_with_unfolding other -> out_id_env -- Not a value or variable - +-} -- If there is an unfolding, we add rhs-info for out_id, -- No need to modify occ info because RHS is pre-simplification out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id @@ -535,7 +566,9 @@ extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env co mkSimplUnfoldingGuidance chkr out_id rhs - = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs + = case calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs of + UnfoldNever -> UnfoldNever + v -> v where inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 879bd2c9da..7a8473e0d0 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -243,46 +243,44 @@ Counting-related monad functions: tick :: TickType -> SmplM () tick tick_type us (SimplCount n stuff) - = ((), SimplCount (n _ADD_ ILIT(1)) #ifdef OMIT_SIMPL_COUNTS - stuff -- don't change anything + = ((), SimplCount (n _ADD_ ILIT(1) stuff)) stuff -- don't change anything #else - (inc_tick stuff) -#endif - ) + = case inc_tick stuff of + [] -> ((), SimplCount (n _ADD_ ILIT(1)) []) + ls -> ((), SimplCount (n _ADD_ ILIT(1)) ls) where inc_tick [] = panic "couldn't inc_tick!" - inc_tick (x@(ttype, cnt) : xs) + inc_tick (x@(ttype, I# cnt#) : xs) = if ttype == tick_type then - let - incd = cnt + 1 - in - (ttype, incd) : xs + case cnt# +# 1# of { incd -> (ttype, IBOX(incd)) : xs } else - x : inc_tick xs + case inc_tick xs of { [] -> [x]; ls -> x:ls } + +#endif tickN :: TickType -> Int -> SmplM () tickN tick_type 0 us counts = ((), counts) tickN tick_type IBOX(increment) us (SimplCount n stuff) - = ((), SimplCount (n _ADD_ increment) #ifdef OMIT_SIMPL_COUNTS - stuff -- don't change anything + = ((), SimplCount (n _ADD_ increment) stuff) -- don't change anything #else - (inc_tick stuff) -#endif - ) + -- force list to avoid getting a chain of @inc_tick@ applications + -- building up on the heap. (Only true when not dumping stats). + = case inc_tick stuff of + [] -> ((), SimplCount (n _ADD_ increment) [] ) + ls -> ((), SimplCount (n _ADD_ increment) ls ) where inc_tick [] = panic "couldn't inc_tick!" - inc_tick (x@(ttype, cnt) : xs) + inc_tick (x@(ttype, I# cnt#) : xs) = if ttype == tick_type then - let - incd = cnt + IBOX(increment) - in - (ttype, incd) : xs + case cnt# +# increment of + incd -> (ttype,IBOX(incd)) : xs else - x : inc_tick xs + case inc_tick xs of { [] -> [x]; ls -> x:ls } +#endif simplCount :: SmplM Int simplCount us sc@(SimplCount n _) = (IBOX(n), sc) @@ -298,8 +296,9 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) stuff1 -- just pick one #else combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) - = SimplCount (n1 _ADD_ n2) - (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2) + = case (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2) of + [] -> SimplCount (n1 _ADD_ n2) [] + ls -> SimplCount (n1 _ADD_ n2) ls #endif \end{code} diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index 506ec80fe3..b2424180fd 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -21,7 +21,11 @@ import Id ( mkIdEnv, lookupIdEnv, SYN_IE(IdEnv), ) import Maybes ( catMaybes ) import OccurAnal ( occurAnalyseBinds ) -import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr ) +import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr, ppPStr, + ppNil + ) +import PprStyle ( PprStyle(..) ) -- added SOF +import PprCore ( pprCoreBinding ) -- added SOF import SimplEnv import SimplMonad import Simplify ( simplTopBinds ) @@ -41,14 +45,12 @@ simplifyPgm :: [CoreBinding] -- input SimplCount) -- accumulated simpl stats simplifyPgm binds s_sw_chkr simpl_stats us - = case (splitUniqSupply us) of { (s1, s2) -> - case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) -> - (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) }} + = --case (splitUniqSupply us) of { (s1, s2) -> + case (initSmpl us (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) -> + (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) } where simpl_switch_is_on = switchIsOn s_sw_chkr - occur_anal = occurAnalyseBinds - max_simpl_iterations = getSimplIntSwitch s_sw_chkr MaxSimplifierIterations simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount) @@ -57,7 +59,7 @@ simplifyPgm binds s_sw_chkr simpl_stats us = -- find out what top-level binders are used, -- and prepare to unfold all the "simple" bindings let - tagged_pgm = occur_anal pgm simpl_switch_is_on + tagged_pgm = _scc_ "OccAnal" occurAnalyseBinds pgm simpl_switch_is_on in -- do the business simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm -> @@ -69,7 +71,7 @@ simplifyPgm binds s_sw_chkr simpl_stats us detailedSimplCount `thenSmpl` \ dr -> let show_status = pprTrace "Simplifer run: " (ppAboves [ - ppBesides [ppStr "iteration ", ppInt iterations, ppStr " out of ", ppInt max_simpl_iterations], + ppBesides [ppPStr SLIT("iteration "), ppInt iterations, ppPStr SLIT(" out of "), ppInt max_simpl_iterations], ppStr (showSimplCount dr), if opt_D_dump_simpl_iterations then ppAboves (map (pprCoreBinding PprDebug) new_pgm) @@ -89,7 +91,7 @@ simplifyPgm binds s_sw_chkr simpl_stats us trace ("NOTE: Simplifier still going after " ++ show max_simpl_iterations ++ - " iterations; baling out.") + " iterations; bailing out.") else id) True else diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 0b0cc562b1..99f3e4c8e9 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -33,7 +33,7 @@ import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppBesides, ppStr ) +--import Pretty ( ppBesides, ppStr ) import SimplEnv import SimplMonad import TyCon ( tyConFamilySize ) @@ -70,12 +70,12 @@ completeVar env var args costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env) = tick UnfoldingDone `thenSmpl_` #ifdef DEBUG - simplCount `thenSmpl` \ n -> - (if n > 3000 then - pprTrace "Ticks > 3000 and unfolding" (ppr PprDebug var) - else - id - ) +-- simplCount `thenSmpl` \ n -> +-- (if n > 3000 then +-- pprTrace "Ticks > 3000 and unfolding" (ppr PprDebug var) +-- else +-- id +-- ) #endif simplExpr unfold_env unf_template args diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 367577ef13..1abccae8c2 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -14,7 +14,7 @@ import StgSyn import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList ) import Id ( idType, mkSysLocal, addIdArity, - mkIdSet, unitIdSet, minusIdSet, + mkIdSet, unitIdSet, minusIdSet, setIdVisibility, unionManyIdSets, idSetToList, SYN_IE(IdSet), nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv) ) @@ -87,11 +87,13 @@ supercombinators on a selective basis: recursive calls, which may now have lots of free vars. Recent Observations: + * 2 might be already ``too many'' variables to abstract. The problem is that the increase in the number of free variables of closures refering to the lifted function (which is always # of abstracted args - 1) may increase heap allocation a lot. Expeiments are being done to check this... + * We do not lambda lift if the function has at least one occurrence without any arguments. This caused lots of problems. Ex: h = \ x -> ... let y = ... @@ -120,8 +122,8 @@ Recent Observations: %************************************************************************ \begin{code} -liftProgram :: UniqSupply -> [StgBinding] -> [StgBinding] -liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog)) +liftProgram :: Module -> UniqSupply -> [StgBinding] -> [StgBinding] +liftProgram mod us prog = concat (runLM mod Nothing us (mapLM liftTopBind prog)) liftTopBind :: StgBinding -> LiftM [StgBinding] @@ -394,7 +396,8 @@ mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body) The monad is used only to distribute global stuff, and the unique supply. \begin{code} -type LiftM a = LiftFlags +type LiftM a = Module + -> LiftFlags -> UniqSupply -> (IdEnv -- Domain = candidates for lifting (Id, -- The supercombinator @@ -407,22 +410,22 @@ type LiftFlags = Maybe Int -- No of fvs reqd to float recursive -- binding; Nothing == infinity -runLM :: LiftFlags -> UniqSupply -> LiftM a -> a -runLM flags us m = m flags us nullIdEnv +runLM :: Module -> LiftFlags -> UniqSupply -> LiftM a -> a +runLM mod flags us m = m mod flags us nullIdEnv thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b -thenLM m k ci us idenv - = k (m ci us1 idenv) ci us2 idenv +thenLM m k mod ci us idenv + = k (m mod ci us1 idenv) mod ci us2 idenv where (us1, us2) = splitUniqSupply us returnLM :: a -> LiftM a -returnLM a ci us idenv = a +returnLM a mod ci us idenv = a fixLM :: (a -> LiftM a) -> LiftM a -fixLM k ci us idenv = r +fixLM k mod ci us idenv = r where - r = k r ci us idenv + r = k r mod ci us idenv mapLM :: (a -> LiftM b) -> [a] -> LiftM [b] mapLM f [] = returnLM [] @@ -442,22 +445,22 @@ newSupercombinator :: Type -> Int -- Arity -> LiftM Id -newSupercombinator ty arity ci us idenv - = (mkSysLocal SLIT("sc") uniq ty noSrcLoc) -- ToDo: improve location +newSupercombinator ty arity mod ci us idenv + = setIdVisibility mod (mkSysLocal SLIT("sc") uniq ty noSrcLoc) `addIdArity` exactArity arity -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it? where uniq = getUnique us lookUp :: Id -> LiftM (Id,[Id]) -lookUp v ci us idenv +lookUp v mod ci us idenv = case (lookupIdEnv idenv v) of Just result -> result Nothing -> (v, []) addScInlines :: [Id] -> [(Id,[Id])] -> LiftM a -> LiftM a -addScInlines ids values m ci us idenv - = m ci us idenv' +addScInlines ids values m mod ci us idenv + = m mod ci us idenv' where idenv' = growIdEnvList idenv (ids `zip_lazy` values) @@ -487,7 +490,7 @@ addScInlines ids values m ci us idenv getFinalFreeVars :: IdSet -> LiftM IdSet -getFinalFreeVars free_vars ci us idenv +getFinalFreeVars free_vars mod ci us idenv = unionManyIdSets (map munge_it (idSetToList free_vars)) where munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real" diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index efa56793c8..7e388378a7 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -15,23 +15,26 @@ import StgSyn import LambdaLift ( liftProgram ) import Name ( isLocallyDefined ) +import UniqSet ( UniqSet(..), mapUniqSet ) import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import StgVarInfo ( setStgVarInfo ) import UpdAnal ( updateAnalyse ) -import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup, +import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC, opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, + opt_DoStgLinting, StgToDo(..) ) import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), + setIdVisibility, GenId{-instance Eq/Outputable -} ) import Maybes ( maybeToBool ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) +import Pretty ( ppShow, ppAbove, ppAboves, ppStr, ppPStr ) import UniqSupply ( splitUniqSupply ) import Util ( mapAccumL, panic, assertPanic ) @@ -54,7 +57,7 @@ stg2stg stg_todos module_name ppr_style us binds (if do_verbose_stg2stg then hPutStr stderr "VERBOSE STG-TO-STG:\n" >> hPutStr stderr (ppShow 1000 - (ppAbove (ppStr ("*** Core2Stg:")) + (ppAbove (ppPStr SLIT("*** Core2Stg:")) (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds))) )) else return ()) >> @@ -66,6 +69,7 @@ stg2stg stg_todos module_name ppr_style us binds -- Do essential wind-up {- Nuked for now SLPJ Dec 96 + -- Essential wind-up: part (a), saturate RHSs -- This must occur *after* elimIndirections, because elimIndirections -- can change things' arities. Consider: @@ -74,7 +78,6 @@ stg2stg stg_todos module_name ppr_style us binds -- Then elimIndirections will change the program to -- x_global = f x -- and lo and behold x_global's arity has changed! - case (satStgRhs processed_binds us4later) of { saturated_binds -> -} @@ -89,13 +92,20 @@ stg2stg stg_todos module_name ppr_style us binds -- correct, which is done by satStgRhs. -- -{- Done in Core now. Nuke soon. SLPJ Nov 96 +{- + Done in Core now. Nuke soon. SLPJ Nov 96 + + No, STG passes may introduce toplevel bindings which + have to be globalised here (later than Core anyway) -- SOF 2/97 + + Yes, lambda lifting now does the Right Thing. + let -- ToDo: provide proper flag control! binds_to_mangle = if not do_unlocalising - then saturated_binds - else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds) + then processed_binds + else snd (unlocaliseStgBinds unlocal_tag nullIdEnv processed_binds) in -} @@ -105,12 +115,18 @@ stg2stg stg_todos module_name ppr_style us binds do_let_no_escapes = opt_StgDoLetNoEscapes do_verbose_stg2stg = opt_D_verbose_stg2stg +{- + (do_unlocalising, unlocal_tag) + = case opt_EnsureSplittableC of + Just tag -> (True, _PK_ tag) + Nothing -> (False, panic "tag") +-} grp_name = case (opt_SccGroup) of Just xx -> _PK_ xx Nothing -> module_name -- default: module name ------------- - stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag + stg_linter = if False --LATER: opt_DoStgLinting (ToDo) then lintStgBindings ppr_style else ( \ whodunnit binds -> binds ) @@ -138,7 +154,7 @@ stg2stg stg_todos module_name ppr_style us binds _scc_ "StgLambdaLift" -- NB We have to do setStgVarInfo first! let - binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds) + binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds) in end_pass us2 "LambdaLift" ccs binds3 @@ -173,4 +189,154 @@ foldl_mn f z (x:xs) = f z x >>= \ zz -> foldl_mn f zz xs \end{code} +%************************************************************************ +%* * +\subsection[SimplStg-unlocalise]{Unlocalisation in STG code} +%* * +%************************************************************************ + +The idea of all this ``unlocalise'' stuff is that in certain (prelude +only) modules we split up the .hc file into lots of separate little +files, which are separately compiled by the C compiler. That gives +lots of little .o files. The idea is that if you happen to mention +one of them you don't necessarily pull them all in. (Pulling in a +piece you don't need can be v bad, because it may mention other pieces +you don't need either, and so on.) + +Sadly, splitting up .hc files means that local names (like s234) are +now globally visible, which can lead to clashes between two .hc +files. So unlocaliseWhatnot goes through making all the local things +into global things, essentially by giving them full names so when they +are printed they'll have their module name too. Pretty revolting +really. + +\begin{code} +type UnlocalEnv = IdEnv Id +lookup_uenv :: UnlocalEnv -> Id -> Id +lookup_uenv env id = case lookupIdEnv env id of + Nothing -> id + Just new_id -> new_id +unlocaliseStgBinds :: FAST_STRING + -> UnlocalEnv + -> [StgBinding] + -> (UnlocalEnv, [StgBinding]) +unlocaliseStgBinds mod uenv [] = (uenv, []) +unlocaliseStgBinds mod uenv (b : bs) = + case unlocal_top_bind mod uenv b of { (new_uenv, new_b) -> + case unlocaliseStgBinds mod new_uenv bs of { (uenv3, new_bs) -> + (uenv3, new_b : new_bs) + }} + +------------------ +unlocal_top_bind :: FAST_STRING + -> UnlocalEnv + -> StgBinding + -> (UnlocalEnv, StgBinding) +unlocal_top_bind mod uenv bind@(StgNonRec binder _) = + let + new_uenv = + case lookupIdEnv uenv binder of + Just global -> uenv + Nothing -> new_env + where + new_env = addOneToIdEnv uenv binder new_global + new_global = setIdVisibility mod binder + in + (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) + +unlocal_top_bind mod uenv bind@(StgRec pairs) = + let + new_env binder uenv = + case lookupIdEnv uenv binder of + Just global -> uenv + Nothing -> env' + where + env' = addOneToIdEnv uenv binder new_global + new_global = setIdVisibility mod binder + + uenv' = foldr (new_env) uenv (map (fst) pairs) + in + (uenv', renameTopStgBind (lookup_uenv uenv') bind) + +\end{code} + +@renameTopStgBind@ renames top level binders and all occurrences thereof. + +\begin{code} +renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding +renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs) +renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] +\end{code} + +This utility function simply applies the given function to every +bindee in the program. + +\begin{code} +mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding +mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs) +mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] + +------------------ +mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs +mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr) + = StgRhsClosure + cc bi + (map fn fvs) + u + (map fn args) + (mapStgBindeesExpr fn expr) + +mapStgBindeesRhs fn (StgRhsCon cc con atoms) + = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms) + +------------------ +mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr + +mapStgBindeesExpr fn (StgApp f args lvs) + = StgApp (mapStgBindeesArg fn f) + (map (mapStgBindeesArg fn) args) + (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgCon con atoms lvs) + = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgPrim op atoms lvs) + = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgLet bind expr) + = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr) + +mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body) + = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs) + (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body) + +mapStgBindeesExpr fn (StgSCC ty label expr) + = StgSCC ty label (mapStgBindeesExpr fn expr) + +mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts) + = StgCase (mapStgBindeesExpr fn expr) + (mapUniqSet fn lvs1) + (mapUniqSet fn lvs2) + uniq + (mapStgBindeesAlts alts) + where + mapStgBindeesAlts (StgAlgAlts ty alts deflt) + = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt) + where + mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr) + + mapStgBindeesAlts (StgPrimAlts ty alts deflt) + = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt) + where + mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr) + + mapStgBindeesDeflt StgNoDefault = StgNoDefault + mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr) + +------------------ +mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg +mapStgBindeesArg fn a@(StgLitArg _) = a +mapStgBindeesArg fn a@(StgConArg _) = a +mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id) +\end{code} diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 6efc6af98d..f9a0949faa 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -48,9 +48,10 @@ For example, if \tr{f}'s @SpecEnv@ contains the mapping: \begin{verbatim} [List a, b] ===> (\d -> f' a b) \end{verbatim} -then +then when we find an application of f to matching types, we simply replace +it by the matching RHS: \begin{verbatim} - f (List Int) Bool d ===> f' Int Bool + f (List Int) Bool ===> (\d -> f' Int Bool) \end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the @@ -89,3 +90,5 @@ lookupSpecEnv (SpecEnv env) tys | otherwise = --pprTrace "lookupSpecEnv" (ppr PprDebug tys) $ lookupMEnv matchTys env tys \end{code} + + diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index beb30cdae9..574ef8ef40 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -10,7 +10,6 @@ module SpecUtils ( specialiseCallTys, SYN_IE(ConstraintVector), getIdOverloading, - mkConstraintVector, isUnboxedSpecialisation, specialiseConstrTys, @@ -23,6 +22,9 @@ module SpecUtils ( IMP_Ubiq(){-uitous-} +import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, + opt_SpecialiseAll + ) import Bag ( isEmptyBag, bagToList ) import Class ( GenClass{-instance NamedThing-}, GenClassOp {- instance NamedThing -} ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, @@ -60,23 +62,19 @@ specialiseTy = panic "SpecUtils.specialiseTy (ToDo)" based on flags, the overloading constraint vector, and the types. \begin{code} -specialiseCallTys :: Bool -- Specialise on all type args - -> Bool -- Specialise on unboxed type args - -> Bool -- Specialise on overloaded type args - -> ConstraintVector -- Tells which type args are overloaded +specialiseCallTys :: ConstraintVector -- Tells which type args are overloaded -> [Type] -- Type args -> [Maybe Type] -- Nothings replace non-specialised type args -specialiseCallTys True _ _ cvec tys - = map Just tys -specialiseCallTys False spec_unboxed spec_overloading cvec tys - = zipWithEqual "specialiseCallTys" spec_ty_other cvec tys +specialiseCallTys cvec tys + | opt_SpecialiseAll = map Just tys + | otherwise = zipWithEqual "specialiseCallTys" spec_ty_other cvec tys where - spec_ty_other c ty | (spec_unboxed && isUnboxedType ty) - || (spec_overloading && c) - = Just ty - | otherwise - = Nothing + spec_ty_other c ty | (opt_SpecialiseUnboxed && isUnboxedType ty) || + (opt_SpecialiseOverloaded && c) + = Just ty + + | otherwise = Nothing \end{code} @getIdOverloading@ grabs the type of an Id, and returns a @@ -119,15 +117,6 @@ getIdOverloading id \begin{code} type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise - -mkConstraintVector :: Id - -> ConstraintVector - -mkConstraintVector id - = [tyvar `elem` constrained_tyvars | tyvar <- tyvars] - where - (tyvars, class_tyvar_pairs) = getIdOverloading id - constrained_tyvars = map snd class_tyvar_pairs -- May contain dups \end{code} \begin{code} @@ -174,9 +163,9 @@ argTysMatchSpecTys_error :: [Maybe Type] argTysMatchSpecTys_error spec_tys arg_tys = if match spec_tys arg_tys then Nothing - else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:", - ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys], - ppStr "argtys=", ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]]) + else Just (ppSep [ppPStr SLIT("Spec and Arg Types Inconsistent:"), + ppPStr SLIT("spectys="), ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys], + ppPStr SLIT("argtys="), ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]]) where match (Nothing:spec_tys) (arg:arg_tys) = not (isUnboxedType arg) && @@ -205,7 +194,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs | otherwise = ppAboves [ - ppStr "SPECIALISATION MESSAGES:", + ppPStr SLIT("SPECIALISATION MESSAGES:"), ppAboves (map pp_module_specs use_modules) ] where @@ -264,7 +253,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs pp_module_specs mod | mod == _NIL_ = ASSERT (null mod_tyspecs) - ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs) + ppAboves (map (pp_idspec ty_sty (ppPStr SLIT("UNKNOWN:"))) mod_idspecs) | have_specs = ppAboves [ @@ -282,15 +271,15 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs ty_sty = PprInterface pp_module mod - = ppBesides [ppPStr mod, ppStr ":"] + = ppBesides [ppPStr mod, ppChar ':'] pp_tyspec :: PprStyle -> Pretty -> (OccName, TyCon, [Maybe Type]) -> Pretty pp_tyspec sty pp_mod (_, tycon, tys) = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", ppStr "data", + ppStr "{-# SPECIALIZE data", pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), - ppStr "#-}", ppStr "{- Essential -}" + ppStr "-} {- Essential -}" ] where tvs = tyConTyVars tycon @@ -305,8 +294,7 @@ pp_idspec :: PprStyle -> Pretty -> (OccName, Id, [Maybe Type], Bool) -> Pretty pp_idspec sty pp_mod (_, id, tys, is_err) | isDictFunId id = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - ppStr "instance", + ppStr "{-# SPECIALIZE instance", pprGenType sty spec_ty, ppStr "#-}", pp_essential ] @@ -329,7 +317,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) ppCat [pp_mod, ppStr "{- instance", pprOccName sty (getOccName cls), - ppStr "EXPLICIT METHOD REQUIRED", + ppPStr SLIT("EXPLICIT METHOD REQUIRED"), pprNonSym sty clsop, ppStr "::", pprGenType sty spec_ty, ppStr "-}", pp_essential ] @@ -337,7 +325,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | otherwise = ppCat [pp_mod, ppStr "{-# SPECIALIZE", - pprNonSym PprForUser id, ppStr "::", + pprNonSym PprForUser id, ppPStr SLIT("::"), pprGenType sty spec_ty, ppStr "#-}", pp_essential ] where diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 80ecd77ea2..0692bd80a4 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -21,9 +21,7 @@ import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, ) import Class ( GenClass{-instance Eq-} ) import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, - opt_CompilingGhcInternals, opt_SpecialiseTrace, - opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, - opt_SpecialiseAll + opt_CompilingGhcInternals, opt_SpecialiseTrace ) import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) import CoreSyn @@ -51,7 +49,7 @@ import PprType ( pprGenType, pprParendGenType, pprMaybeTy, GenType{-instance Outputable-}, GenTyVar{-ditto-}, TyCon{-ditto-} ) -import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, +import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, ppPStr, ppChar, ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty) ) import PrimOp ( PrimOp(..) ) @@ -75,8 +73,13 @@ import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual, infixr 9 `thenSM` +specProgram = panic "SpecProgram" + --ToDo:kill data SpecInfo = SpecInfo [Maybe Type] Int Id + + +{- lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)" addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)" cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)" @@ -688,12 +691,12 @@ data CallInstance \begin{code} pprCI :: CallInstance -> Pretty pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) - = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id]) + = ppHang (ppCat [ppPStr SLIT("Call inst for"), ppr PprDebug id]) 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), case maybe_specinfo of Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts]) Just (SpecInfo _ _ spec_id) - -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id] + -> ppCat [ppPStr SLIT("Explicit SpecId"), ppr PprDebug spec_id] ]) -- ToDo: instance Outputable CoreArg? @@ -765,9 +768,9 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i) cis_here_list = bagToList cis_here in -- pprTrace "getCIs:" - -- (ppHang (ppBesides [ppStr "{", + -- (ppHang (ppBesides [ppChar '{', -- interppSP PprDebug ids, - -- ppStr "}"]) + -- ppChar '}']) -- 4 (ppAboves (map pprCI cis_here_list))) (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i) @@ -794,12 +797,12 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids then pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++ " (may be a non-HM recursive call)\n") - (ppHang (ppBesides [ppStr "{", + (ppHang (ppBesides [ppChar '{', interppSP PprDebug bound_ids, - ppStr "}"]) - 4 (ppAboves [ppStr "Dumping CIs:", + ppChar '}']) + 4 (ppAboves [ppPStr SLIT("Dumping CIs:"), ppAboves (map pprCI (bagToList cis_of_bound_id)), - ppStr "Instantiating CIs:", + ppPStr SLIT("Instantiating CIs:"), ppAboves (map pprCI inst_cis)])) else id) ( if top_lev || floating then @@ -807,9 +810,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids else (if not (isEmptyBag cis_dump_unboxed) then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n" - (ppHang (ppBesides [ppStr "{", + (ppHang (ppBesides [ppChar '{', interppSP PprDebug full_ids, - ppStr "}"]) + ppChar '}']) 4 (ppAboves (map pprCI (bagToList cis_dump)))) else id) cis_keep_not_bound_id @@ -907,9 +910,9 @@ data UsageDetails Int -- no. of spec insts \end{code} -The DictBindDetails are fully processed; their call-instance information is -incorporated in the call-instances of the -UsageDetails which includes the DictBindDetails. The free vars in a usage details +The DictBindDetails are fully processed; their call-instance +information is incorporated in the call-instances of the UsageDetails +which includes the DictBindDetails. The free vars in a usage details will *include* the binders of the DictBind details. A @DictBindDetails@ contains bindings for dictionaries *only*. @@ -1081,6 +1084,8 @@ data CloneInfo %************************************************************************ \begin{code} +-} + data SpecialiseData = SpecData Bool -- True <=> Specialisation performed @@ -1114,6 +1119,8 @@ data SpecialiseData initSpecData local_tycons tycon_specs = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag + +{- \end{code} ToDo[sansom]: Transformation data to process specialisation requests. @@ -1159,8 +1166,8 @@ specProgram uniqs binds in (if opt_D_simplifier_stats then pprTrace "\nSpecialiser Stats:\n" (ppAboves [ - ppBesides [ppStr "SpecCalls ", ppInt spec_calls], - ppBesides [ppStr "SpecInsts ", ppInt spec_insts], + ppBesides [ppPStr SLIT("SpecCalls "), ppInt spec_calls], + ppBesides [ppPStr SLIT("SpecInsts "), ppInt spec_insts], ppSP]) else id) @@ -1204,7 +1211,7 @@ specTyConsAndScope scopeM (if opt_SpecialiseTrace && not (null tycon_specs_list) then pprTrace "Specialising TyCons:\n" (ppAboves [ if not (null specs) then - ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"]) + ppHang (ppCat [(ppr PprDebug tycon), ppPStr SLIT("at types")]) 4 (ppAboves (map pp_specs specs)) else ppNil | (tycon, specs) <- tycon_specs_list]) @@ -1284,7 +1291,7 @@ specExpr :: CoreExpr -- expression. specExpr (Var v) args - = lookupId v `thenSM` \ vlookup -> + = specId v $ \ lookupId v `thenSM` \ vlookup -> case vlookup of Lifted vl vu -> -- Binding has been lifted, need to extract un-lifted value @@ -1298,6 +1305,7 @@ specExpr (Var v) args mkCallInstance v new_v arg_info `thenSM` \ call_uds -> mkCall new_v arg_info `thenSM` \ call -> let + call mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos]) uds = unionUDList [call_uds, singleFvUDs vatom, unionUDList [uds | (_,uds,_) <- arg_info] @@ -1311,37 +1319,22 @@ specExpr expr@(Lit _) null_args specExpr (Con con args) null_args = ASSERT (null null_args) - let - (targs, vargs) = partition_args args - in - mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) -> - mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> - mkTyConInstance con tys `thenSM` \ con_uds -> - returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)), - unionUDList args_uds_s `unionUDs` con_uds) + specArgs args $ \ args' -> + mkTyConInstance con args' `thenSM` \ con_uds -> + returnSM (Con con args', con_uds) specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args = ASSERT (null null_args) - let - (targs, vargs) = partition_args args - in - ASSERT (null targs) - mapSM specTy arg_tys `thenSM` \ arg_tys -> - specTy res_ty `thenSM` \ res_ty -> - mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> - returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs), - unionUDList args_uds_s) + specArgs args $ \ args' -> + mapSM specTy arg_tys `thenSM` \ arg_tys' -> + specTy res_ty `thenSM` \ res_ty' -> + returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs) specExpr (Prim prim args) null_args = ASSERT (null null_args) - let - (targs, vargs) = partition_args args - in - mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) -> - mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> + specArgs args $ \ args' -> -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) -> - returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)), - unionUDList args_uds_s {-`unionUDs` prim_uds-} ) + returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} ) {- ToDo: specPrimOp @@ -1362,7 +1355,7 @@ specPrimOp :: PrimOp specExpr (App fun arg) args = -- If TyArg, arg will be processed; otherwise, left alone - preSpecArg arg `thenSM` \ new_arg -> + specArg arg `thenSM` \ new_arg -> specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> returnSM (expr, uds) @@ -1570,45 +1563,42 @@ partition_args args is_ty_arg _ = False ---------- -preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else - -preSpecArg (TyArg ty) - = specTy ty `thenSM` \ new_ty -> - returnSM (TyArg new_ty) - -preSpecArg other = returnSM other - --------------------- -specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) - -specValArg (LitArg lit) - = returnSM (LitArg lit, emptyUDs, id) - -specValArg (VarArg v) +specId :: Id + -> (Id -> SpecM (CoreExpr, UsageDetails)) + -> SpecM (CoreExpr, UsageDetails) +specId v = lookupId v `thenSM` \ vlookup -> case vlookup of + Lifted vl vu - -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu) + -> thing_inside vu `thenSM` \ (expr, uds) -> + returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds) NoLift vatom - -> returnSM (vatom, singleFvUDs vatom, id) + -> thing_inside vatom `thenSM` \ (expr, uds) -> + returnSM (expr, singleFvUDs vatom `unionUDs` uds) +specArg :: CoreArg + -> (CoreArg -> SpecM (CoreExpr, UsageDetails)) + -> SpecM (CoreExpr, UsageDetails)) ------------------- -specTyArg (TyArg ty) +specArg (TyArg ty) thing_inside = specTy ty `thenSM` \ new_ty -> - returnSM (TyArg new_ty, new_ty) + thing_inside (TyArg new_ty) --------------- -specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) +specArg (LitArg lit) + = thing_inside (LitArg lit) -specOutArg (TyArg ty) -- already speced; no action - = returnSM (TyArg ty, emptyUDs, id) +specArg (VarArg v) -specOutArg other_arg -- unprocessed; spec the atom - = specValArg other_arg + +specArgs [] thing_inside + = thing_inside [] + +specArgs (arg:args) thing_inside + = specArg arg $ \ arg' -> + specArgs args $ \ args' -> + thing_inside (arg' : args') \end{code} @@ -1839,9 +1829,9 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis else if top_lev then pprTrace "dumpCIs: not same overloading ... top level \n" else (\ x y -> y) - ) (ppHang (ppBesides [ppStr "{", + ) (ppHang (ppBesides [ppPStr SLIT("{"), interppSP PprDebug new_ids, - ppStr "}"]) + ppPStr SLIT("}")]) 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids), ppAboves (map pprCI (concat equiv_ciss))])) (returnSM ([], emptyUDs, [])) @@ -1907,21 +1897,21 @@ OK, so we have: We return a new definition - f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2 + $f1 = /\a -> orig_rhs t1 a t3 d1 d2 -The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat) +The SpecInfo for f will be: - SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3 + SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a) Based on this SpecInfo, a call instance of f - ...(f t1 t2 t3 d1 d2)... + ...(f t1 t2 t3)... should get replaced by - ...(f@t1//t3 t2)... + ...(\d1 d2 -> $f1 t2)... -(But that is the business of @mkCall@.) +(But that is the business of the simplifier.) \begin{code} mkOneInst :: CallInstance @@ -2031,18 +2021,18 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis trace_nospec str spec_id = pprTrace str (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys), - ppStr "==>", ppr PprDebug spec_id]) + ppPStr SLIT("==>"), ppr PprDebug spec_id]) in (if opt_SpecialiseTrace then pprTrace "Specialising:" - (ppHang (ppBesides [ppStr "{", + (ppHang (ppBesides [ppChar '{', interppSP PprDebug new_ids, - ppStr "}"]) + ppChar '}']) 4 (ppAboves [ - ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)], + ppBesides [ppPStr SLIT("types: "), ppInterleave ppNil (map pp_ty arg_tys)], if isExplicitCI do_cis then ppNil else - ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)], - ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]])) + ppBesides [ppPStr SLIT("dicts: "), ppInterleave ppNil (map pp_dict dict_args)], + ppBesides [ppPStr SLIT("specs: "), ppr PprDebug spec_ids]])) else id) ( do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) -> @@ -2067,7 +2057,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis \begin{code} mkCallInstance :: Id -> Id - -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] + -> [CoreArg] -> SpecM UsageDetails mkCallInstance id new_id [] @@ -2093,30 +2083,30 @@ mkCallInstance id new_id args | otherwise = let - spec_overloading = opt_SpecialiseOverloaded - spec_unboxed = opt_SpecialiseUnboxed - spec_all = opt_SpecialiseAll - (tyvars, class_tyvar_pairs) = getIdOverloading id + constrained_tyvars = map snd class_tyvar_pairs -- May contain dups + constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars] - arg_res = take_type_args tyvars class_tyvar_pairs args + arg_res = take_type_args tyvars class_tyvar_pairs args enough_args = maybeToBool arg_res + (Just (tys, dicts, rest_args)) = arg_res record_spec id tys = (record, lookup, spec_tys) where - spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading - (mkConstraintVector id) tys + spec_tys = specialiseCallTys constraint_vec tys record = any (not . isTyVarTy) (catMaybes spec_tys) lookup = lookupSpecEnv (getIdSpecialisation id) tys in if (not enough_args) then - pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t" - (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args])) + pprTrace "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t" + (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) args)) $ + returnSM emptyUDs + else case record_spec id tys of (False, _, _) @@ -2130,7 +2120,7 @@ mkCallInstance id new_id args else -- pprTrace "CallInst:Reqd\n" -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys), + -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys), -- ppCat (map (ppr PprDebug) dicts)]]) (returnSM (singleCI new_id spec_tys dicts)) @@ -2142,37 +2132,37 @@ mkCallInstance id new_id args (False, _, _) -> -- pprTrace "CallInst:Exists\n" -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, + -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, -- ppr PprDebug (tys_left ++ drop toss dicts)]]) (returnSM emptyUDs) (True, Nothing, spec_tys) -> -- pprTrace "CallInst:Exists:Reqd\n" -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, + -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, -- ppr PprDebug (tys_left ++ drop toss dicts)], - -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys), + -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys), -- ppCat (map (ppr PprDebug) (drop toss dicts))]]) (returnSM (singleCI spec_id spec_tys (drop toss dicts))) (True, Just (spec_spec_id, tys_left_left, toss_toss), _) -> -- pprTrace "CallInst:Exists:Exists\n" -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, + -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, -- ppr PprDebug (tys_left ++ drop toss dicts)], - -- ppCat [ppStr "->", ppr PprDebug spec_spec_id, + -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_spec_id, -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]]) (returnSM emptyUDs) else -- pprTrace "CallInst:Exists\n" -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppStr "->", ppr PprDebug spec_id, + -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, -- ppr PprDebug (tys_left ++ drop toss dicts)]]) (returnSM emptyUDs) -take_type_args (_:tyvars) class_tyvar_pairs ((TyArg ty,_,_):args) +take_type_args (_:tyvars) class_tyvar_pairs (TyArg ty : args) = case (take_type_args tyvars class_tyvar_pairs args) of Nothing -> Nothing Just (tys, dicts, others) -> Just (ty:tys, dicts, others) @@ -2184,7 +2174,7 @@ take_type_args [] class_tyvar_pairs args Nothing -> Nothing Just (dicts, others) -> Just ([], dicts, others) -take_dict_args (_:class_tyvar_pairs) ((dict,_,_):args) | isValArg dict +take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict = case (take_dict_args class_tyvar_pairs args) of Nothing -> Nothing Just (dicts, others) -> Just (dict:dicts, others) @@ -2199,7 +2189,7 @@ mkCall :: Id -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] -> SpecM CoreExpr -mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos]) +mkCall new_id arg_infos = returnSM ( {- | maybeToBool (isSuperDictSelId_maybe new_id) @@ -2259,7 +2249,7 @@ mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args), - ppStr "==>", + ppPStr SLIT("==>"), ppr PprDebug spec_id]) else let @@ -2320,17 +2310,17 @@ mkTyConInstance con tys case record_inst of Nothing -- No TyCon instance -> -- pprTrace "NoTyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", + -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"), -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)]) (returnSM (singleConUDs con)) Just spec_tys -- Record TyCon instance -> -- pprTrace "TyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", + -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"), -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys), - -- ppBesides [ppStr "(", + -- ppBesides [ppChar '(', -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], - -- ppStr ")"]]) + -- ppChar ')']]) (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) where tycon = dataConTyCon con @@ -2352,7 +2342,7 @@ recordTyConInst con tys tys) in -- pprTrace "ConSpecExists?: " - -- (ppAboves [ppStr (if spec_exists then "True" else "False"), + -- (ppAboves [ppPStr (if spec_exists then SLIT("True") else SLIT("False")), -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)]) (if (not spec_exists && do_tycon_spec) then returnSM (Just spec_tys) @@ -2600,4 +2590,5 @@ mapAndUnzip4SM f [] = returnSM ([],[],[],[]) mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) -> mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) -> returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4)) +-} \end{code} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 4ef43a4a93..6c2206a116 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -57,11 +57,11 @@ lintStgBindings sty whodunnit binds case (initL (lint_binds binds)) of Nothing -> binds Just msg -> pprPanic "" (ppAboves [ - ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"), + ppPStr SLIT("*** Stg Lint Errors: in "),ppStr whodunnit, ppPStr SLIT(" ***"), msg sty, - ppStr "*** Offending Program ***", + ppPStr SLIT("*** Offending Program ***"), ppAboves (map (pprPlainStgBinding sty) binds), - ppStr "*** End of Offense ***"]) + ppPStr SLIT("*** End of Offense ***")]) where lint_binds :: [StgBinding] -> LintM () @@ -279,22 +279,22 @@ data LintLocInfo instance Outputable LintLocInfo where ppr sty (RhsOf v) - = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + = ppBesides [ppr sty (getSrcLoc v), ppPStr SLIT(": [RHS of "), pp_binders sty [v], ppChar ']'] ppr sty (LambdaBodyOf bs) = ppBesides [ppr sty (getSrcLoc (head bs)), - ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"] + ppPStr SLIT(": [in body of lambda with binders "), pp_binders sty bs, ppChar ']'] ppr sty (BodyOfLetRec bs) = ppBesides [ppr sty (getSrcLoc (head bs)), - ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + ppPStr SLIT(": [in body of letrec with binders "), pp_binders sty bs, ppChar ']'] pp_binders :: PprStyle -> [Id] -> Pretty pp_binders sty bs = ppInterleave ppComma (map pp_binder bs) where pp_binder b - = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)] + = ppCat [ppr sty b, ppPStr SLIT("::"), ppr sty (idType b)] \end{code} \begin{code} @@ -423,7 +423,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs checkInScope :: Id -> LintM () checkInScope id loc scope errs = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfIdSet` scope) then - ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) + ((), addErr errs (\ sty -> ppCat [ppr sty id, ppPStr SLIT("is out of scope")]) loc) else ((), errs) @@ -443,38 +443,38 @@ mkCaseAltMsg alts sty mkCaseDataConMsg :: StgExpr -> ErrMsg mkCaseDataConMsg expr sty - = ppAbove (ppStr "A case scrutinee not a type-constructor type:") + = ppAbove (ppPStr SLIT("A case scrutinee not a type-constructor type:")) (pp_expr sty expr) mkCaseAbstractMsg :: TyCon -> ErrMsg mkCaseAbstractMsg tycon sty - = ppAbove (ppStr "An algebraic case on an abstract type:") + = ppAbove (ppPStr SLIT("An algebraic case on an abstract type:")) (ppr sty tycon) mkDefltMsg :: StgCaseDefault -> ErrMsg mkDefltMsg deflt sty - = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:") + = ppAbove (ppPStr SLIT("Binder in default case of a case expression doesn't match type of scrutinee:")) --LATER: (ppr sty deflt) (panic "mkDefltMsg") mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg mkFunAppMsg fun_ty arg_tys expr sty = ppAboves [ppStr "In a function application, function type doesn't match arg types:", - ppHang (ppStr "Function type:") 4 (ppr sty fun_ty), - ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + ppHang (ppPStr SLIT("Function type:")) 4 (ppr sty fun_ty), + ppHang (ppPStr SLIT("Arg types:")) 4 (ppAboves (map (ppr sty) arg_tys)), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkRhsConMsg :: Type -> [Type] -> ErrMsg mkRhsConMsg fun_ty arg_tys sty = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:", - ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty), - ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))] + ppHang (ppPStr SLIT("Constructor type:")) 4 (ppr sty fun_ty), + ppHang (ppPStr SLIT("Arg types:")) 4 (ppAboves (map (ppr sty) arg_tys))] mkUnappTyMsg :: Id -> Type -> ErrMsg mkUnappTyMsg var ty sty = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.", - ppBeside (ppStr "Var: ") (ppr sty var), - ppBeside (ppStr "Its type: ") (ppr sty ty)] + ppBeside (ppPStr SLIT("Var: ")) (ppr sty var), + ppBeside (ppPStr SLIT("Its type: ")) (ppr sty ty)] mkAlgAltMsg1 :: Type -> ErrMsg mkAlgAltMsg1 ty sty @@ -512,10 +512,10 @@ mkPrimAltMsg alt sty mkRhsMsg :: Id -> Type -> ErrMsg mkRhsMsg binder ty sty - = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + = ppAboves [ppCat [ppPStr SLIT("The type of this binder doesn't match the type of its RHS:"), ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)], - ppCat [ppStr "Rhs type:", ppr sty ty] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)], + ppCat [ppPStr SLIT("Rhs type:"), ppr sty ty] ] pp_expr :: PprStyle -> StgExpr -> Pretty diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 1e86a91005..411e968b07 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -505,12 +505,12 @@ pprStgBinding sty (StgNonRec bndr rhs) 4 (ppBeside (ppr sty rhs) ppSemi) pprStgBinding sty (StgCoerceBinding bndr occ) - = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"]) + = ppHang (ppCat [ppr sty bndr, ppEquals, ppPStr SLIT("{-Coerce-}")]) 4 (ppBeside (ppr sty occ) ppSemi) pprStgBinding sty (StgRec pairs) - = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) : - (map (ppr_bind sty) pairs)) + = ppAboves ((ifPprDebug sty (ppPStr SLIT("{- StgRec (begin) -}"))) : + (map (ppr_bind sty) pairs) ++ [(ifPprDebug sty (ppPStr SLIT("{- StgRec (end) -}")))]) where ppr_bind sty (bndr, expr) = ppHang (ppCat [ppr sty bndr, ppEquals]) @@ -561,11 +561,11 @@ pprStgExpr sty (StgApp func args lvs) \begin{code} pprStgExpr sty (StgCon con args lvs) = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs), - ppStr "! [", interppSP sty args, ppStr "]" ] + ppPStr SLIT("! ["), interppSP sty args, ppChar ']' ] pprStgExpr sty (StgPrim op args lvs) = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs, - ppStr " [", interppSP sty args, ppStr "]" ] + ppPStr SLIT(" ["), interppSP sty args, ppChar ']' ] \end{code} \begin{code} @@ -580,62 +580,62 @@ pprStgExpr sty (StgPrim op args lvs) pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) expr@(StgLet _ _)) = ppAbove - (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ", + (ppHang (ppBesides [ppPStr SLIT("let { "), ppr sty bndr, ppPStr SLIT(" = "), ppStr (showCostCentre sty True{-as string-} cc), pp_binder_info sty bi, - ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\", - ppr sty upd_flag, ppStr " [", - interppSP sty args, ppStr "]"]) - 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]])) + ppPStr SLIT(" ["), ifPprDebug sty (interppSP sty free_vars), ppPStr SLIT("] \\"), + ppr sty upd_flag, ppPStr SLIT(" ["), + interppSP sty args, ppChar ']']) + 8 (ppSep [ppCat [ppr sty rhs, ppPStr SLIT("} in")]])) (ppr sty expr) -- special case: let ... in let ... pprStgExpr sty (StgLet bind expr@(StgLet _ _)) = ppAbove - (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])]) + (ppSep [ppHang (ppPStr SLIT("let {")) 2 (ppCat [pprStgBinding sty bind, ppPStr SLIT("} in")])]) (ppr sty expr) -- general case pprStgExpr sty (StgLet bind expr) - = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind), - ppHang (ppStr "} in ") 2 (ppr sty expr)] + = ppSep [ppHang (ppPStr SLIT("let {")) 2 (pprStgBinding sty bind), + ppHang (ppPStr SLIT("} in ")) 2 (ppr sty expr)] pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr) - = ppSep [ppHang (ppStr "let-no-escape {") + = ppSep [ppHang (ppPStr SLIT("let-no-escape {")) 2 (pprStgBinding sty bind), - ppHang (ppBeside (ppStr "} in ") + ppHang (ppBeside (ppPStr SLIT("} in ")) (ifPprDebug sty ( ppNest 4 ( - ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), - ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), - ppStr "]"])))) + ppBesides [ppPStr SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole), + ppPStr SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss), + ppChar ']'])))) 2 (ppr sty expr)] \end{code} \begin{code} pprStgExpr sty (StgSCC ty cc expr) - = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)], + = ppSep [ ppCat [ppPStr SLIT("_scc_"), ppStr (showCostCentre sty True{-as string-} cc)], pprStgExpr sty expr ] \end{code} \begin{code} pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) - = ppSep [ppSep [ppStr "case", + = ppSep [ppSep [ppPStr SLIT("case"), ppNest 4 (ppCat [pprStgExpr sty expr, - ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]), - ppStr "of {"], + ifPprDebug sty (ppBeside (ppPStr SLIT("::")) (pp_ty alts))]), + ppPStr SLIT("of {")], ifPprDebug sty ( ppNest 4 ( - ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), - ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), - ppStr "]; uniq: ", pprUnique uniq])), + ppBesides [ppPStr SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole), + ppPStr SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss), + ppPStr SLIT("]; uniq: "), pprUnique uniq])), ppNest 2 (ppr_alts sty alts), - ppStr "}"] + ppChar '}'] where ppr_default sty StgNoDefault = ppNil ppr_default sty (StgBindDefault bndr used expr) - = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) + = ppHang (ppCat [pp_binder, ppPStr SLIT("->")]) 4 (ppr sty expr) where pp_binder = if used then ppr sty bndr else ppChar '_' @@ -647,7 +647,7 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) ppr_default sty deflt ] where ppr_bxd_alt sty (con, params, use_mask, expr) - = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"]) + = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppPStr SLIT("->")]) 4 (ppBeside (ppr sty expr) ppSemi) ppr_alts sty (StgPrimAlts ty alts deflt) @@ -655,7 +655,7 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) ppr_default sty deflt ] where ppr_ubxd_alt sty (lit, expr) - = ppHang (ppCat [ppr sty lit, ppStr "->"]) + = ppHang (ppCat [ppr sty lit, ppPStr SLIT("->")]) 4 (ppBeside (ppr sty expr) ppSemi) \end{code} @@ -679,19 +679,19 @@ pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), pp_binder_info sty bi, - ppStr " [", ifPprDebug sty (ppr sty free_var), - ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ] + ppPStr SLIT(" ["), ifPprDebug sty (ppr sty free_var), + ppPStr SLIT("] \\"), ppr sty upd_flag, ppPStr SLIT(" [] "), ppr sty func ] -- general case pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body) = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), pp_binder_info sty bi, - ppStr " [", ifPprDebug sty (interppSP sty free_vars), - ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"]) + ppPStr SLIT(" ["), ifPprDebug sty (interppSP sty free_vars), + ppPStr SLIT("] \\"), ppr sty upd_flag, ppPStr SLIT(" ["), interppSP sty args, ppChar ']']) 4 (ppr sty body) pprStgRhs sty (StgRhsCon cc con args) = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), - ppSP, ppr sty con, ppStr "! [", interppSP sty args, ppStr "]" ] + ppSP, ppr sty con, ppPStr SLIT("! ["), interppSP sty args, ppChar ']' ] -------------- pp_binder_info PprForUser _ = ppNil diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index db1310cd72..eb2723072d 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -31,7 +31,7 @@ import MagicUFs ( MagicUnfoldingFun ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * []-} ) import PprStyle ( PprStyle(..) ) -import Pretty ( ppStr ) +import Pretty ( ppPStr ) import PrimOp ( PrimOp(..) ) import SaLib import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, @@ -432,11 +432,11 @@ absId anal var env -- Try the strictness info absValFromStrictness anal strictness_info in - -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) $ + -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppPStr SLIT("=:"), pp_anal anal, ppStr SLIT(":="),ppr PprDebug result]) $ result where - pp_anal StrAnal = ppStr "STR" - pp_anal AbsAnal = ppStr "ABS" + pp_anal StrAnal = ppPStr SLIT("STR") + pp_anal AbsAnal = ppPStr SLIT("ABS") absEvalAtom anal (VarArg v) env = absId anal v env absEvalAtom anal (LitArg _) env = AbsTop diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 786333aad0..3f5c7fa93f 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -29,7 +29,7 @@ import IdInfo ( StrictnessInfo(..) ) import Demand ( Demand{-instance Outputable-} ) import Outputable ( Outputable(..){-instance * []-} ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppStr, ppCat ) +import Pretty ( ppPStr, ppCat, ppChar ) \end{code} %************************************************************************ @@ -74,15 +74,15 @@ data AbsVal -- argument if the Demand so indicates. instance Outputable AbsVal where - ppr sty AbsTop = ppStr "AbsTop" - ppr sty AbsBot = ppStr "AbsBot" - ppr sty (AbsProd prod) = ppCat [ppStr "AbsProd", ppr sty prod] + ppr sty AbsTop = ppPStr SLIT("AbsTop") + ppr sty AbsBot = ppPStr SLIT("AbsBot") + ppr sty (AbsProd prod) = ppCat [ppPStr SLIT("AbsProd"), ppr sty prod] ppr sty (AbsFun arg body env) - = ppCat [ppStr "AbsFun{", ppr sty arg, - ppStr "???", -- ppStr "}{env:", ppr sty (keysFM env `zip` eltsFM env), - ppStr "}" ] + = ppCat [ppPStr SLIT("AbsFun{"), ppr sty arg, + ppPStr SLIT("???"), -- ppStr "}{env:", ppr sty (keysFM env `zip` eltsFM env), + ppChar '}' ] ppr sty (AbsApproxFun demand val) - = ppCat [ppStr "AbsApprox ", ppr sty demand, ppStr "", ppr sty val ] + = ppCat [ppPStr SLIT("AbsApprox "), ppr sty demand, ppr sty val ] \end{code} %----------- diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index f3946f8661..5013b29392 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -27,7 +27,7 @@ import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo, import PprCore ( pprCoreBinding, pprBigCoreBinder ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) -import Pretty ( ppBesides, ppStr, ppInt, ppChar, ppAboves ) +import Pretty ( ppBesides, ppPStr, ppInt, ppChar, ppAboves ) import SaAbsInt import SaLib import TyVar ( GenTyVar{-instance Eq-} ) @@ -123,9 +123,9 @@ saWwTopBinds us binds where pp_stats (SaStats tlam dlam tc dc tlet dlet) = pprTrace "Binders marked demanded: " - (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam), - ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc), - ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet) + (ppBesides [ppPStr SLIT("Lambda vars: "), ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam), + ppPStr SLIT("; Case vars: "), ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc), + ppPStr SLIT("; Let vars: "), ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet) ]) #endif \end{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 318a6d2a1a..3f21e6d1a5 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -326,7 +326,7 @@ mkWW ((arg,WwUnpack True cs) : ds) -- The main event: a single-constructor data type (arg_tycon, tycon_arg_tys, data_con) - Just (_, _, data_cons) -> panic "mk_ww_arg_processing: not one constr" + Just (_, _, data_cons) -> panic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" Nothing -> panic "mk_ww_arg_processing: not datatype" diff --git a/ghc/compiler/tests/Makefile b/ghc/compiler/tests/Makefile index 70541f9a9b..c4d6742251 100644 --- a/ghc/compiler/tests/Makefile +++ b/ghc/compiler/tests/Makefile @@ -1,6 +1,6 @@ -TOP = ../../.. -include $(TOP)/ghc/mk/ghc.mk +TOP = ../.. +include $(TOP)/mk/boilerplate.mk SUBDIRS = reader rename simplCore typecheck deSugar printing ccall deriving -include $(TOP)/mk/subdir.mk +include $(TOP)/mk/target.mk diff --git a/ghc/compiler/tests/deSugar/Makefile b/ghc/compiler/tests/deSugar/Makefile index 38f5c876dc..e6dc7936e6 100644 --- a/ghc/compiler/tests/deSugar/Makefile +++ b/ghc/compiler/tests/deSugar/Makefile @@ -1,14 +1,17 @@ -TOP = ../../../.. -GhcRunTestRules = YES -# These options apply to all tests -RUNSTDTEST_OPTS = -noC -ddump-ds -dcore-lint -include $(TOP)/ghc/mk/ghc.mk +TOP = ../../.. +include $(TOP)/mk/boilerplate.mk runtests :: $(patsubst %.hs, %.runtest, $(wildcard *.hs)) @echo 'TODO: ds014a -- some things that should NOT go through' #SUBDIRS = cvh-ds-unboxed +# These options apply to all tests +RUN_TEST_OPTS = -noC -ddump-ds -dcore-lint + ds030_flags = -dppr-all ds035_flags = -fglasgow-exts ds039_flags = -dppr-all + + +include $(TOP)/mk/target.mk diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs deleted file mode 100644 index f231f897fc..0000000000 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ /dev/null @@ -1,451 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[GenSpecEtc]{Code for GEN, SPEC, PRED, and REL} - -\begin{code} -#include "HsVersions.h" - -module GenSpecEtc ( - TcSigInfo(..), - genBinds, - checkSigTyVars - ) where - -IMP_Ubiq() - -import TcMonad -import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE, - newDicts, tyVarsOfInst, instToId ) -import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars ) -import SpecEnv ( SpecEnv ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) -import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType), - SYN_IE(TcTyVarSet), SYN_IE(TcTyVar), - newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars - ) -import Unify ( unifyTauTy ) - -import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..), - Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake - ) -import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcExpr), tcIdType ) - -import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag ) -import Class ( GenClass ) -import Id ( GenId, SYN_IE(Id), mkUserId, idType ) -import Kind ( isUnboxedTypeKind, isTypeKind, mkBoxedTypeKind ) -import ListSetOps ( minusList, unionLists, intersectLists ) -import Maybes ( allMaybes ) -import Name ( Name{--O only-} ) -import Outputable ( interppSP, interpp'SP ) -import Pretty -import PprType ( GenClass, GenType, GenTyVar ) -import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys, - getTyVar, getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta ) -import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet, - elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) -import Usage ( SYN_IE(UVar) ) -import Unique ( Unique ) -import Util -\end{code} - -%************************************************************************ -%* * -\subsection[Gen-SignatureInfo]{The @TcSigInfo@ type} -%* * -%************************************************************************ - -A type signature (or user-pragma) is typechecked to produce a -@TcSigInfo@. It contains @TcTypes@ because they are unified with -the variable's type, and after that checked to see whether they've -been instantiated. - -\begin{code} -data TcSigInfo s - = TySigInfo (TcIdBndr s) -- for this value... - [TcTyVar s] (TcThetaType s) (TcTauType s) - SrcLoc -\end{code} - - -%************************************************************************ -%* * -\subsection[Gen-GEN]{Generalising bindings} -%* * -%************************************************************************ - -\begin{code} -genBinds :: [Name] -- Binders - -> [TcIdBndr s] -- Monomorphic binders - -> TcBind s -- Type-checked monobind - -> LIE s -- LIE from typecheck of binds - -> [TcSigInfo s] -- Signatures, if any - -> (Name -> PragmaInfo) -- Gives pragma info for binder - -> TcM s (TcHsBinds s, LIE s, [TcIdBndr s]) -\end{code} - -In the call $(@genBinds@~env~bind~lie~lve)$, $(bind,lie,lve)$ -is the result of typechecking a @Bind@. @genBinds@ implements the BIND-GEN -and BIND-PRED rules. -$lie$ and $lve$ may or may not be -fixed points of the current substitution. - -It returns -\begin{itemize} -\item -An @AbsBind@ which wraps up $bind$ in a suitable abstraction. -\item -an LIE, which is the part of the input LIE which isn't discharged by -the AbsBind. This means the parts which predicate type variables -free in $env$. -\item -An LVE whose domain is identical to that passed in. -Its range is a new set of locals to that passed in, -because they have been gen'd. -\end{itemize} - -@genBinds@ takes the -following steps: -\begin{itemize} -\item -find $constrained$, the free variables of $env$. -First we must apply the current substitution to the environment, so that the -correct set of constrained type vars are extracted! -\item -find $free$, the free variables of $lve$ which are not in $constrained$. -We need to apply the current subsitution to $lve$ first, of course. -\item -minimise $lie$ to give $lie'$; all the constraints in $lie'$ are on -single type variables. -\item -split $lie'$ into three: those predicating type variables in $constrained$, -those on type variables in $free$, and the rest. -\item -complain about ``the rest'' part of $lie'$. These type variables are -ambiguous. -\item -generate new locals for each member of the domain of $lve$, with appropriately -gen'd types. -\item -generate a suitable AbsBinds to enclose the bindings. -\end{itemize} - -\begin{code} -genBinds binder_names mono_ids bind lie sig_infos prag_info_fn - = -- CHECK THAT THE SIGNATURES MATCH - -- Doesn't affect substitution - mapTc checkSigMatch sig_infos `thenTc_` - - -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE IDENTICAL - -- The type signatures on a mutually-recursive group of definitions - -- must all have the same context (or none). - -- We have to zonk them first to make their type variables line up - mapNF_Tc get_zonked_theta sig_infos `thenNF_Tc` \ thetas -> - checkTc (null thetas || all (eqSimpleTheta (head thetas)) (tail thetas)) - (sigContextsErr sig_infos) `thenTc_` - - -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen - mapNF_Tc (zonkTcType . idType) mono_ids `thenNF_Tc` \ mono_id_types -> - tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> - let - mentioned_tyvars = tyVarsOfTypes mono_id_types - tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars - tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- sig_infos] - in - - -- DEAL WITH OVERLOADING - resolveOverloading tyvars_to_gen lie bind tysig_vars (head thetas) - `thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) -> - - -- Check for generalisation over unboxed types, and - -- default any TypeKind TyVars to BoxedTypeKind - let - tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order - - unboxed_kind_tyvars = filter (isUnboxedTypeKind . tyVarKind) tyvars - unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars - - box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty -> - unifyTauTy boxed_ty (mkTyVarTy tyvar) - - in - ASSERT( null unboxed_kind_tyvars ) -- The instCantBeGeneralised stuff in tcSimplify - -- should have dealt with unboxed type variables; - -- and it's better done there because we have more - -- precise origin information - - -- Default any TypeKind variables to BoxedTypeKind - mapTc box_it unresolved_kind_tyvars `thenTc_` - - -- BUILD THE NEW LOCALS - let - dict_tys = map tcIdType dicts_bound - poly_tys = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types - poly_ids = zipWithEqual "genspecetc" mk_poly binder_names poly_tys - mk_poly name ty = mkUserId name ty (prag_info_fn name) - in - -- BUILD RESULTS - returnTc ( - AbsBinds tyvars - dicts_bound - (zipEqual "genBinds" (map TcId mono_ids) (map TcId poly_ids)) - dict_binds - bind, - lie', - poly_ids - ) - -get_zonked_theta (TySigInfo _ _ theta _ _) - = mapNF_Tc (\ (c,t) -> zonkTcType t `thenNF_Tc` \ t' -> returnNF_Tc (c,t')) theta -\end{code} - - -\begin{code} -resolveOverloading - :: TcTyVarSet s -- Tyvars over which we are going to generalise - -> LIE s -- The LIE to deal with - -> TcBind s -- The binding group - -> [TcIdBndr s] -- Variables in type signatures - -> TcThetaType s -- *Zonked* theta for the overloading in type signature - -- (if there are any type signatures; error otherwise) - -> TcM s (LIE s, -- LIE to pass up the way; a fixed point of - -- the current substitution - TcTyVarSet s, -- Revised tyvars to generalise - [(TcIdOcc s, TcExpr s)], -- Dict bindings - [TcIdOcc s]) -- List of dicts to bind here - -resolveOverloading tyvars_to_gen dicts bind tysig_vars theta - | not (isUnRestrictedGroup tysig_vars bind) - = -- Restricted group, so bind no dictionaries, and - -- remove from tyvars_to_gen any constrained type variables - - -- *Don't* simplify dicts at this point, because we aren't going - -- to generalise over these dicts. By the time we do simplify them - -- we may well know more. For example (this actually came up) - -- f :: Array Int Int - -- f x = array ... xs where xs = [1,2,3,4,5] - -- We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) - -- stuff. If we simplify only at the f-binding (not the xs-binding) - -- we'll know that the literals are all Ints, and we can just produce - -- Int literals! - - -- Find all the type variables involved in overloading, the "constrained_tyvars" - -- These are the ones we *aren't* going to generalise. - -- We must be careful about doing this: - -- (a) If we fail to generalise a tyvar which is not actually - -- constrained, then it will never, ever get bound, and lands - -- up printed out in interface files! Notorious example: - -- instance Eq a => Eq (Foo a b) where .. - -- Here, b is not constrained, even though it looks as if it is. - -- Another, more common, example is when there's a Method inst in - -- the LIE, whose type might very well involve non-overloaded - -- type variables. - -- (b) On the other hand, we mustn't generalise tyvars which are constrained, - -- because we are going to pass on out the unmodified LIE, with those - -- tyvars in it. They won't be in scope if we've generalised them. - -- - -- So we are careful, and do a complete simplification just to find the - -- constrained tyvars. We don't use any of the results, except to - -- find which tyvars are constrained. - - tcSimplify tyvars_to_gen dicts `thenTc` \ (_, _, dicts_sig) -> - let - -- ASSERT: dicts_sig is already zonked! - constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet dicts_sig - reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars - in - - -- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen: - -- We still need to do this simplification, because some dictionaries - -- may gratuitouslyconstrain some tyvars over which we *are* going - -- to generalise. - -- For example d::Eq (Foo a b), where Foo is instanced as above. - tcExtendGlobalTyVars constrained_tyvars ( - tcSimplify reduced_tyvars_to_gen dicts - ) - `thenTc` \ (dicts_free, dicts_binds, dicts_sig2) -> - ASSERT(isEmptyBag dicts_sig2) - - returnTc (dicts_free, -- All these are left unbound - reduced_tyvars_to_gen, - dicts_binds, -- Local dict binds - []) -- No lambda-bound dicts - - -- The returned LIE should be a fixed point of the substitution - - | null tysig_vars -- An unrestricted group with no type signaturs - = tcSimplify tyvars_to_gen dicts `thenTc` \ (dicts_free, dict_binds, dicts_sig) -> - returnTc (dicts_free, tyvars_to_gen, dict_binds, - map instToId (bagToList dicts_sig)) - - | otherwise -- An unrestricted group with type signatures - = tcAddErrCtxt (sigsCtxt tysig_vars) $ - newDicts SignatureOrigin theta `thenNF_Tc` \ (dicts_sig, dict_ids) -> - -- It's important that theta is pre-zonked, because - -- dict_id is later used to form the type of the polymorphic thing, - -- and forall-types must be zonked so far as their bound variables - -- are concerned - - -- Check that the needed dicts can be expressed in - -- terms of the signature ones - tcSimplifyAndCheck - tyvars_to_gen -- Type vars over which we will quantify - dicts_sig -- Available dicts - dicts -- Want bindings for these dicts - - `thenTc` \ (dicts_free, dict_binds) -> - - returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids) -\end{code} - -@checkSigMatch@ does the next step in checking signature matching. -The tau-type part has already been unified. What we do here is to -check that this unification has not over-constrained the (polymorphic) -type variables of the original signature type. - -The error message here is somewhat unsatisfactory, but it'll do for -now (ToDo). - -\begin{code} -checkSigMatch :: TcSigInfo s -> TcM s () - -checkSigMatch (TySigInfo id sig_tyvars _ tau_ty src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (sigCtxt id) $ - checkSigTyVars sig_tyvars tau_ty -\end{code} - - -%************************************************************************ -%* * -\subsection[GenEtc-monomorphism]{The monomorphism restriction} -%* * -%************************************************************************ - -Not exported: - -\begin{code} -isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these - -> TcBind s - -> Bool - -isUnRestrictedGroup sigs EmptyBind = True -isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds -isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds - -is_elem v vs = isIn "isUnResMono" v vs - -isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs -isUnResMono sigs (PatMonoBind other _ _) = False -isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs -isUnResMono sigs (FunMonoBind _ _ _ _) = True -isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && - isUnResMono sigs mb2 -isUnResMono sigs EmptyMonoBinds = True -\end{code} - - -%************************************************************************ -%* * -\subsection[GenEtc-sig]{Matching a type signature} -%* * -%************************************************************************ - -@checkSigTyVars@ is used after the type in a type signature has been unified with -the actual type found. It then checks that the type variables of the type signature -are - (a) still all type variables - eg matching signature [a] against inferred type [(p,q)] - [then a will be unified to a non-type variable] - - (b) still all distinct - eg matching signature [(a,b)] against inferred type [(p,p)] - [then a and b will be unified together] - -BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS - - (c) not mentioned in the environment - eg the signature for f in this: - - g x = ... where - f :: a->[a] - f y = [x,y] - - Here, f is forced to be monorphic by the free occurence of x. - -Before doing this, the substitution is applied to the signature type variable. - -\begin{code} -checkSigTyVars :: [TcTyVar s] -- The original signature type variables - -> TcType s -- signature type (for err msg) - -> TcM s () - -checkSigTyVars sig_tyvars sig_tau - = tcGetGlobalTyVars `thenNF_Tc` \ globals -> - let - mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars - in - -- TEMPORARY FIX - -- Until the final Bind-handling stuff is in, several type signatures in the same - -- bindings group can cause the signature type variable from the different - -- signatures to be unified. So we still need to zonk and check point (b). - -- Remove when activating the new binding code - mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys -> - checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys)) - (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> - failTc (badMatchErr sig_tau sig_tau') - ) `thenTc_` - - - -- Check point (c) - -- We want to report errors in terms of the original signature tyvars, - -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond - -- 1-1 with sig_tyvars, so we can just map back. - checkTc (null mono_tyvars) - (notAsPolyAsSigErr sig_tau mono_tyvars) -\end{code} - - - - -Contexts and errors -~~~~~~~~~~~~~~~~~~~ -\begin{code} -notAsPolyAsSigErr sig_tau mono_tyvars sty - = ppHang (ppStr "A type signature is more polymorphic than the inferred type") - 4 (ppAboves [ppStr "Some type variables in the inferred type can't be forall'd, namely:", - interpp'SP sty mono_tyvars, - ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction" - ]) -\end{code} - - -\begin{code} -badMatchErr sig_ty inferred_ty sty - = ppHang (ppStr "Type signature doesn't match inferred type") - 4 (ppAboves [ppHang (ppStr "Signature:") 4 (ppr sty sig_ty), - ppHang (ppStr "Inferred :") 4 (ppr sty inferred_ty) - ]) - -sigCtxt id sty - = ppSep [ppStr "When checking signature for", ppr sty id] -sigsCtxt ids sty - = ppSep [ppStr "When checking signature(s) for:", interpp'SP sty ids] -\end{code} - - -\begin{code} -sigContextsErr ty_sigs sty - = ppHang (ppStr "A group of type signatures have mismatched contexts") - 4 (ppAboves (map ppr_sig_info ty_sigs)) - where - ppr_sig_info (TySigInfo val tyvars theta tau_ty _) - = ppHang (ppBeside (ppr sty val) (ppStr " :: ")) - 4 (if null theta - then ppNil - else ppBesides [ppStr "(", - ppIntersperse (ppStr ", ") (map (ppr_inst sty) theta), - ppStr ") => ..."]) - ppr_inst sty (clas, ty) = ppCat [ppr sty clas, ppr sty ty] -\end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 0c6d0c5192..8911251617 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -32,7 +32,7 @@ IMP_Ubiq() IMPORT_1_3(Ratio(Rational)) import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity, - InPat, OutPat, Stmt, Qualifier, Match, + InPat, OutPat, Stmt, DoOrListComp, Match, ArithSeqInfo, HsType, Fake ) import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr), @@ -367,7 +367,7 @@ ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc) 4 (ppCat [case lit of OverloadedIntegral i -> ppInteger i OverloadedFractional f -> ppRational f, - ppStr "at", + ppPStr SLIT("at"), ppr sty ty, show_uniq sty u]) @@ -377,7 +377,7 @@ ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc) ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc) = ppHang (ppr_orig orig loc) - 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u]) + 4 (ppCat [ppr sty id, ppPStr SLIT("at"), interppSP sty tys, show_uniq sty u]) show_uniq PprDebug u = ppr PprDebug u show_uniq sty u = ppNil @@ -502,8 +502,8 @@ lookupSimpleInst class_inst_env clas ty (_, theta, _) = splitSigmaTy (idType dfun) noSimpleInst clas ty sty - = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas), - ppStr "at type", ppQuote (ppr sty ty)] + = ppSep [ppPStr SLIT("No instance for class"), ppQuote (ppr sty clas), + ppPStr SLIT("at type"), ppQuote (ppr sty ty)] \end{code} @@ -642,31 +642,31 @@ pprOrigin hdr orig locn ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"), ppr sty id, ppChar '\''] InstanceDeclOrigin -> - ppStr "in an instance declaration" + ppPStr SLIT("in an instance declaration") LiteralOrigin lit -> - ppCat [ppStr "at an overloaded literal:", ppr sty lit] + ppCat [ppPStr SLIT("at an overloaded literal:"), ppr sty lit] ArithSeqOrigin seq -> - ppCat [ppStr "at an arithmetic sequence:", ppr sty seq] + ppCat [ppPStr SLIT("at an arithmetic sequence:"), ppr sty seq] SignatureOrigin -> - ppStr "in a type signature" + ppPStr SLIT("in a type signature") DoOrigin -> - ppStr "in a do statement" + ppPStr SLIT("in a do statement") ClassDeclOrigin -> - ppStr "in a class declaration" + ppPStr SLIT("in a class declaration") InstanceSpecOrigin _ clas ty -> ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", ppr sty clas, ppStr "\" type: ", ppr sty ty] ValSpecOrigin name -> - ppBesides [ppStr "in a SPECIALIZE user-pragma for `", - ppr sty name, ppStr "'"] + ppBesides [ppPStr SLIT("in a SPECIALIZE user-pragma for `"), + ppr sty name, ppChar '\''] CCallOrigin clabel Nothing{-ccall result-} -> - ppBesides [ppStr "in the result of the _ccall_ to `", - ppStr clabel, ppStr "'"] + ppBesides [ppPStr SLIT("in the result of the _ccall_ to `"), + ppStr clabel, ppChar '\''] CCallOrigin clabel (Just arg_expr) -> - ppBesides [ppStr "in an argument in the _ccall_ to `", + ppBesides [ppPStr SLIT("in an argument in the _ccall_ to `"), ppStr clabel, ppStr "', namely: ", ppr sty arg_expr] LitLitOrigin s -> - ppBesides [ppStr "in this ``literal-literal'': ", ppStr s] + ppBesides [ppPStr SLIT("in this ``literal-literal'': "), ppStr s] UnknownOrigin -> - ppStr "in... oops -- I don't know where the overloading came from!" + ppPStr SLIT("in... oops -- I don't know where the overloading came from!") \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index ffafeb71d7..75b3683a5a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -6,47 +6,64 @@ \begin{code} #include "HsVersions.h" -module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where +module TcBinds ( tcBindsAndThen, tcPragmaSigs, checkSigTyVars ) where IMP_Ubiq() import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), - HsExpr, Match, HsType, InPat, OutPat(..), - GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, + Match, HsType, InPat(..), OutPat(..), HsExpr(..), + GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, Stmt, DoOrListComp, Fixity, collectBinders ) import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..), SYN_IE(RenamedMonoBinds) ) import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds), - TcIdOcc(..), SYN_IE(TcIdBndr) ) + TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), + tcIdType + ) import TcMonad -import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) ) -import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) ) -import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds ) +import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..), + newDicts, tyVarsOfInst, instToId + ) +import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds, + tcGetGlobalTyVars, tcExtendGlobalTyVars + ) import SpecEnv ( SpecEnv ) IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) import TcMatches ( tcMatchesFun ) +import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) import TcMonoType ( tcHsType ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTcTyVar, tcInstSigType, newTyVarTys ) +import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType), + SYN_IE(TcTyVarSet), SYN_IE(TcTyVar), + newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars, + newTcTyVar, tcInstSigType, newTyVarTys + ) import Unify ( unifyTauTy ) -import Kind ( mkBoxedTypeKind, mkTypeKind ) +import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind ) import Id ( GenId, idType, mkUserLocal, mkUserId ) import IdInfo ( noIdInfo ) import Maybes ( assocMaybe, catMaybes ) import Name ( pprNonSym, getOccName, getSrcLoc, Name ) import PragmaInfo ( PragmaInfo(..) ) import Pretty -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, - mkSigmaTy, splitSigmaTy, +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta, + mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, splitRhoTy, mkForAllTy, splitForAllTy ) -import Bag ( bagToList ) -import Util ( isIn, zipEqual, zipWith3Equal, panic ) +import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet, + elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) +import Bag ( bagToList, foldrBag, isEmptyBag ) +import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc, + assertPanic, panic ) +import PprType ( GenClass, GenType, GenTyVar ) +import Unique ( Unique ) +import Outputable ( interppSP, interpp'SP ) \end{code} + %************************************************************************ %* * \subsection{Type-checking bindings} @@ -64,7 +81,7 @@ specialising the things bound. @tcBindsAndThen@ also takes a "combiner" which glues together the bindings and the "thing" to make a new "thing". -The real work is done by @tcBindAndThen@. +The real work is done by @tcBindWithSigsAndThen@. Recursive and non-recursive binds are handled in essentially the same way: because of uniques there are no scoping issues left. The only @@ -90,10 +107,10 @@ tcBindsAndThen combiner EmptyBinds do_next returnTc (combiner EmptyBinds thing, lie, thing_ty) tcBindsAndThen combiner (SingleBind bind) do_next - = tcBindAndThen combiner bind [] do_next + = tcBindWithSigsAndThen combiner bind [] do_next tcBindsAndThen combiner (BindWith bind sigs) do_next - = tcBindAndThen combiner bind sigs do_next + = tcBindWithSigsAndThen combiner bind sigs do_next tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next) @@ -128,14 +145,17 @@ tcBindsAndThen (ThenBinds binds1 binds2) do_next returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty) \end{pseudocode} + %************************************************************************ %* * -\subsection{Bind} +\subsection{tcBindWithSigsAndThen} %* * %************************************************************************ +@tcBindAndThen@ deals with one binding group and the thing it scopes over. + \begin{code} -tcBindAndThen +tcBindWithSigsAndThen :: (TcHsBinds s -> thing -> thing) -- Combinator -> RenamedBind -- The Bind to typecheck -> [RenamedSig] -- ...and its signatures @@ -143,13 +163,29 @@ tcBindAndThen -- augmented envt -> TcM s (thing, LIE s, thing_ty) -- Results, incl the -tcBindAndThen combiner bind sigs do_next - = fixTc (\ ~(prag_info_fn, _) -> +tcBindWithSigsAndThen combiner bind sigs do_next + = + recoverTc ( + -- If typechecking the binds fails, then return with each + -- binder given type (forall a.a), to minimise subsequent + -- error messages + newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv -> + let + forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) + poly_ids = [ mkUserId name forall_a_a NoPragmaInfo + | name <- binder_names] + in + -- Extend the environment to bind the new polymorphic Ids + -- and do the thing inside + tcExtendLocalValEnv binder_names poly_ids $ + do_next + ) $ + + fixTc (\ ~(prag_info_fn, _) -> -- This is the usual prag_info fix; the PragmaInfo field of an Id -- is not inspected till ages later in the compiler, so there -- should be no black-hole problems here. - - tcBindAndSigs binder_names bind + tcBindWithSigs binder_names bind sigs prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) -> -- Extend the environment to bind the new polymorphic Ids @@ -177,23 +213,21 @@ tcBindAndThen combiner bind sigs do_next returnTc result where binder_names = map fst (bagToList (collectBinders bind)) +\end{code} -tcBindAndSigs binder_names bind sigs prag_info_fn - = recoverTc ( - -- If typechecking the binds fails, then return with each - -- binder given type (forall a.a), to minimise subsequent - -- error messages - newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv -> - let - forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - poly_ids = [ mkUserId name forall_a_a (prag_info_fn name) - | name <- binder_names] - in - returnTc (EmptyBinds, emptyLIE, poly_ids) - ) $ +%************************************************************************ +%* * +\subsection{tcBindWithSigs} +%* * +%************************************************************************ - -- Create a new identifier for each binder, with each being given +@tcBindWithSigs@ deals with a single binding group. It does generalisation, +so all the clever stuff is in here. + +\begin{code} +tcBindWithSigs binder_names bind sigs prag_info_fn + = -- Create a new identifier for each binder, with each being given -- a fresh unique, and a type-variable type. tcGetUniques no_of_binders `thenNF_Tc` \ uniqs -> newTyVarTys no_of_binders kind `thenNF_Tc` \ tys -> @@ -201,126 +235,112 @@ tcBindAndSigs binder_names bind sigs prag_info_fn mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs tys mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name) in - tcExtendLocalValEnv binder_names mono_ids ( - tcTySigs sigs `thenTc` \ sig_info -> - tc_bind bind `thenTc` \ (bind', lie) -> - returnTc (bind', lie, sig_info) - ) - `thenTc` \ (bind', lie, sig_info) -> - -- Notice that genBinds gets the old (non-extended) environment - genBinds binder_names mono_ids bind' lie sig_info prag_info_fn - where - no_of_binders = length binder_names - kind = case bind of - NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types - RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types -\end{code} + -- TYPECHECK THE SIGNATURES + mapTc tcTySig ty_sigs `thenTc` \ tc_ty_sigs -> + + -- TYPECHECK THE BINDINGS + tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) -> + + -- CHECK THAT THE SIGNATURES MATCH + -- (must do this before getTyVarsToGen) + checkSigMatch (binder_names `zip` mono_ids) tc_ty_sigs `thenTc` \ sig_theta -> + + -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen + -- The tyvars_not_to_gen are free in the environment, and hence + -- candidates for generalisation, but sometimes the monomorphism + -- restriction means we can't generalise them nevertheless + mapNF_Tc (zonkTcType . idType) mono_ids `thenNF_Tc` \ mono_id_types -> + getTyVarsToGen is_unrestricted mono_id_types lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) -> + let + tyvars_to_gen_list = tyVarSetToList tyvars_to_gen -- Commit to a particular order + in + -- SIMPLIFY THE LIE + tcExtendGlobalTyVars tyvars_not_to_gen ( + if null tc_ty_sigs then + -- No signatures, so just simplify the lie + tcSimplify tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) -> + returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) -=========== -\begin{code} -{- + else + newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (dicts_sig, dict_ids) -> + -- It's important that sig_theta is zonked, because + -- dict_id is later used to form the type of the polymorphic thing, + -- and forall-types must be zonked so far as their bound variables + -- are concerned -data SigInfo - = SigInfo Name - (TcIdBndr s) -- Polymorpic version - (TcIdBndr s) -- Monomorphic verstion - [TcType s] [TcIdOcc s] -- Instance information for the monomorphic version + -- Check that the needed dicts can be expressed in + -- terms of the signature ones + tcAddErrCtxt (sigsCtxt tysig_names) $ + tcSimplifyAndCheck tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) -> + returnTc (lie_free, dict_binds, dict_ids) + ) `thenTc` \ (lie_free, dict_binds, dicts_bound) -> + -- DEAL WITH TYPE VARIABLE KINDS + defaultUncommittedTyVars tyvars_to_gen_list `thenTc_` - -- Deal with type signatures - tcTySigs sigs `thenTc` \ sig_infos -> + -- BUILD THE POLYMORPHIC RESULT IDs let - sig_binders = [binder | SigInfo binder _ _ _ _ <- sig_infos] - poly_sigs = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos] - mono_sigs = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos] - nosig_binders = binders `minusList` sig_binders + dict_tys = map tcIdType dicts_bound + poly_tys = map (mkForAllTys tyvars_to_gen_list . mkFunTys dict_tys) mono_id_types + poly_ids = zipWithEqual "genspecetc" mk_poly binder_names poly_tys + mk_poly name ty = mkUserId name ty (prag_info_fn name) in + -- MAKE EXTRA BINDS FOR THE TYPE-SIG POLYMORPHIC VARIABLES + -- These are only needed to scope over the right-hand sides of the group, + -- and hence aren't needed at all for non-recursive definitions. + -- + -- Alas, the polymorphic variables from the type signature can't coincide + -- with the poly_ids because the order of their type variables may not be + -- the same. These bindings just swizzle the type variables. + let + poly_binds | is_rec_bind = map mk_poly_bind tc_ty_sigs + | otherwise = [] + + mk_poly_bind (TySigInfo name rhs_poly_id rhs_tyvars _ _ _) + = (TcId rhs_poly_id, TyLam rhs_tyvars $ + TyApp (HsVar (TcId main_poly_id)) $ + mkTyVarTys tyvars_to_gen_list) + where + main_poly_id = head (filter ((== name) . getName) poly_ids) + in + -- BUILD RESULTS + returnTc ( + AbsBinds tyvars_to_gen_list + dicts_bound + (zipEqual "genBinds" (map TcId mono_ids) (map TcId poly_ids)) + (poly_binds ++ dict_binds) + (wrap_it mbind'), + lie_free, + poly_ids + ) + where + no_of_binders = length binder_names - -- Typecheck the binding group - tcExtendLocalEnv poly_sigs ( - newLocalIds nosig_binders kind (\ nosig_local_ids -> - tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies -> - returnTc (nosig_local_ids, binds_w_lies) - )) `thenTc` \ (nosig_local_ids, binds_w_lies) -> - - - -- Decide what to generalise over - getImplicitStuffToGen sig_ids binds_w_lies - `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) -> - - - *** CHECK FOR UNBOXED TYVARS HERE! *** + is_rec_bind = case bind of + NonRecBind _ -> False + RecBind _ -> True + mbind = case bind of + NonRecBind mb -> mb + RecBind mb -> mb + ty_sigs = [sig | sig@(Sig name _ _) <- sigs] + tysig_names = [name | (Sig name _ _) <- ty_sigs] + is_unrestricted = isUnRestrictedGroup tysig_names mbind - -- Make poly_ids for all the binders that don't have type signatures - let - tys_to_gen = mkTyVarTys tyvars_to_gen - dicts_to_gen = map instToId (bagToList lie_to_gen) - dict_tys = map tcIdType dicts_to_gen - - mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo - where - ty = mkForAllTys tyvars_to_gen $ - mkFunTys dict_tys $ - tcIdType local_id - - more_sig_infos = [ SigInfo binder (mk_poly binder local_id) - local_id tys_to_gen dicts_to_gen lie_to_gen - | (binder, local_id) <- zipEqual "???" nosig_binders nosig_local_ids - ] - - all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder - in + kind | is_rec_bind = mkBoxedTypeKind -- Recursive, so no unboxed types + | otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types + wrap_it mbind | is_rec_bind = RecBind mbind + | otherwise = NonRecBind mbind - -- Now generalise the bindings - let - -- local_binds is a bunch of bindings of the form - -- f_mono = f_poly tyvars dicts - -- one for each binder, f, that lacks a type signature. - -- This bunch of bindings is put at the top of the RHS of every - -- binding in the group, so as to bind all the f_monos. - - local_binds = [ (local_id, mkHsDictApp (mkHsTyApp (HsVar local_id) tys_to_gen) dicts_to_gen) - | local_id <- nosig_local_ids - ] - - find_sig lid = head [ (pid, tvs, ds, lie) - | SigInfo _ pid lid' tvs ds lie, - lid==lid' - ] - - gen_bind (bind, lie) - = tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie - `thenTc` \ (lie_free, dict_binds) -> - returnTc (AbsBind tyvars_to_gen_here - dicts - (zipEqual "gen_bind" local_ids poly_ids) - (dict_binds ++ local_binds) - bind, - lie_free) - where - local_ids = bindersOf bind - local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos, - local_id `elem` local_ids - ] - - (tyvars_to_gen_here, dicts, avail) - = case (local_ids, sigs) of - - ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie]) - -> (tyvars_to_gen, dicts, lie) - - other -> (tyvars_to_gen, dicts, avail) \end{code} -@getImplicitStuffToGen@ decides what type variables -and LIE to generalise over. +@getImplicitStuffToGen@ decides what type variables generalise over. For a "restricted group" -- see the monomorphism restriction for a definition -- we bind no dictionaries, and @@ -336,9 +356,10 @@ stuff. If we simplify only at the f-binding (not the xs-binding) we'll know that the literals are all Ints, and we can just produce Int literals! -Find all the type variables involved in overloading, the "constrained_tyvars". -These are the ones we *aren't* going to generalise. -We must be careful about doing this: +Find all the type variables involved in overloading, the +"constrained_tyvars". These are the ones we *aren't* going to +generalise. We must be careful about doing this: + (a) If we fail to generalise a tyvar which is not actually constrained, then it will never, ever get bound, and lands up printed out in interface files! Notorious example: @@ -347,6 +368,7 @@ We must be careful about doing this: Another, more common, example is when there's a Method inst in the LIE, whose type might very well involve non-overloaded type variables. + (b) On the other hand, we mustn't generalise tyvars which are constrained, because we are going to pass on out the unmodified LIE, with those tyvars in it. They won't be in scope if we've generalised them. @@ -356,86 +378,115 @@ constrained tyvars. We don't use any of the results, except to find which tyvars are constrained. \begin{code} -getImplicitStuffToGen is_restricted sig_ids binds_w_lies - | isUnRestrictedGroup tysig_vars bind - = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, dicts_to_gen) -> - returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen) - - | otherwise - = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> - let +getTyVarsToGen is_unrestricted mono_id_types lie + = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> + let + mentioned_tyvars = tyVarsOfTypes mono_id_types + tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars + in + if is_unrestricted + then + returnTc (emptyTyVarSet, tyvars_to_gen) + else + tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> + let -- ASSERT: dicts_sig is already zonked! - constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts - reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars - in - returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE) - - where - sig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs] - - (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2, - lie1 `plusLIE` lie2)) - get - (emptyTyVarSet, emptyLIE) - binds_w_lies - get (bind, lie) - = case bindersOf bind of - [local_id] | local_id `in` sig_ids -> -- A simple binding with - -- a type signature - (emptyTyVarSet, emptyLIE) - - local_ids -> -- Complex binding or no type sig - (foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids, - lie) --} + constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts + reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars + in + returnTc (constrained_tyvars, reduced_tyvars_to_gen) \end{code} - \begin{code} -tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s) +isUnRestrictedGroup :: [Name] -- Signatures given for these + -> RenamedMonoBinds + -> Bool -tc_bind (NonRecBind mono_binds) - = tcMonoBinds mono_binds `thenTc` \ (mono_binds2, lie) -> - returnTc (NonRecBind mono_binds2, lie) +is_elem v vs = isIn "isUnResMono" v vs -tc_bind (RecBind mono_binds) - = tcMonoBinds mono_binds `thenTc` \ (mono_binds2, lie) -> - returnTc (RecBind mono_binds2, lie) +isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs +isUnRestrictedGroup sigs (PatMonoBind other _ _) = False +isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs +isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True +isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && + isUnRestrictedGroup sigs mb2 +isUnRestrictedGroup sigs EmptyMonoBinds = True \end{code} -\begin{code} -tcMonoBinds :: RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s) - -tcMonoBinds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE) - -tcMonoBinds (AndMonoBinds mb1 mb2) - = tcMonoBinds mb1 `thenTc` \ (mb1a, lie1) -> - tcMonoBinds mb2 `thenTc` \ (mb2a, lie2) -> - returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2) +@defaultUncommittedTyVars@ checks for generalisation over unboxed +types, and defaults any TypeKind TyVars to BoxedTypeKind. -tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn) - = tcAddSrcLoc locn $ +\begin{code} +defaultUncommittedTyVars tyvars + = ASSERT( null unboxed_kind_tyvars ) -- The instCantBeGeneralised stuff in tcSimplify + -- should have dealt with unboxed type variables; + -- and it's better done there because we have more + -- precise origin information. + -- That's why we call this *after* simplifying. + -- (NB: unboxed tyvars are always introduced along + -- with a class constraint.) + + mapTc box_it unresolved_kind_tyvars + where + unboxed_kind_tyvars = filter (isUnboxedTypeKind . tyVarKind) tyvars + unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars - -- LEFT HAND SIDE - tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) -> + box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty -> + unifyTauTy boxed_ty (mkTyVarTy tyvar) +\end{code} - -- BINDINGS AND GRHSS - tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) -> - -- Unify the two sides - tcAddErrCtxt (patMonoBindsCtxt bind) $ - unifyTauTy pat_ty grhss_ty `thenTc_` +%************************************************************************ +%* * +\subsection{tcMonoBind} +%* * +%************************************************************************ - -- RETURN - returnTc (PatMonoBind pat2 grhss_and_binds2 locn, - plusLIE lie_pat lie) +@tcMonoBinds@ deals with a single @MonoBind@. +The signatures have been dealt with already. -tcMonoBinds (FunMonoBind name inf matches locn) - = tcAddSrcLoc locn $ - tcLookupLocalValueOK "tcMonoBinds" name `thenNF_Tc` \ id -> - tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) -> - returnTc (FunMonoBind (TcId id) inf matches' locn, lie) +\begin{code} +tcMonoBinds :: RenamedMonoBinds + -> [Name] -> [TcIdBndr s] + -> [TcSigInfo s] + -> TcM s (TcMonoBinds s, LIE s) + +tcMonoBinds mbind binder_names mono_ids tc_ty_sigs + = tcExtendLocalValEnv binder_names mono_ids ( + tc_mono_binds mbind + ) + where + sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs] + sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs] + + tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE) + + tc_mono_binds (AndMonoBinds mb1 mb2) + = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) -> + tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) -> + returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2) + + tc_mono_binds (FunMonoBind name inf matches locn) + = tcAddSrcLoc locn $ + tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id -> + + -- Before checking the RHS, extend the envt with + -- bindings for the *polymorphic* Ids from any type signatures + tcExtendLocalValEnv sig_names sig_ids $ + tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) -> + + returnTc (FunMonoBind (TcId id) inf matches' locn, lie) + + tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn) + = tcAddSrcLoc locn $ + tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) -> + tcExtendLocalValEnv sig_names sig_ids $ + tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) -> + tcAddErrCtxt (patMonoBindsCtxt bind) $ + unifyTauTy pat_ty grhss_ty `thenTc_` + returnTc (PatMonoBind pat2 grhss_and_binds2 locn, + plusLIE lie_pat lie) \end{code} %************************************************************************ @@ -449,28 +500,128 @@ tcMonoBinds (FunMonoBind name inf matches locn) split up, and have fresh type variables installed. All non-type-signature "RenamedSigs" are ignored. +The @TcSigInfo@ contains @TcTypes@ because they are unified with +the variable's type, and after that checked to see whether they've +been instantiated. + \begin{code} -tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s] +data TcSigInfo s + = TySigInfo Name + (TcIdBndr s) -- *Polymorphic* binder for this value... + [TcTyVar s] (TcThetaType s) (TcTauType s) + SrcLoc +\end{code} -tcTySigs (Sig v ty src_loc : other_sigs) - = tcAddSrcLoc src_loc ( - tcHsType ty `thenTc` \ sigma_ty -> - tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> - let - (tyvars', theta', tau') = splitSigmaTy sigma_ty' - in - tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val -> - unifyTauTy (idType val) tau' `thenTc_` +\begin{code} +tcTySig :: RenamedSig -> TcM s (TcSigInfo s) + +tcTySig (Sig v ty src_loc) + = tcAddSrcLoc src_loc $ + tcHsType ty `thenTc` \ sigma_ty -> + tcGetUnique `thenNF_Tc` \ uniq -> + tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> + let + poly_id = mkUserLocal (getOccName v) uniq sigma_ty' src_loc + (tyvars', theta', tau') = splitSigmaTy sigma_ty' + in + returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc) +\end{code} - returnTc (TySigInfo val tyvars' theta' tau' src_loc) - ) `thenTc` \ sig_info1 -> +@checkSigMatch@ does the next step in checking signature matching. +The tau-type part has already been unified. What we do here is to +check that this unification has not over-constrained the (polymorphic) +type variables of the original signature type. - tcTySigs other_sigs `thenTc` \ sig_infos -> - returnTc (sig_info1 : sig_infos) +The error message here is somewhat unsatisfactory, but it'll do for +now (ToDo). + +\begin{code} +checkSigMatch binder_names_w_mono_isd [] + = returnTc (error "checkSigMatch") -tcTySigs (other : sigs) = tcTySigs sigs -tcTySigs [] = returnTc [] +checkSigMatch binder_names_w_mono_ids tc_ty_sigs + = + + -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK + -- Doesn't affect substitution + mapTc check_one_sig tc_ty_sigs `thenTc_` + + -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE IDENTICAL + -- The type signatures on a mutually-recursive group of definitions + -- must all have the same context (or none). + -- We have to zonk them first to make their type variables line up + mapNF_Tc get_zonked_theta tc_ty_sigs `thenNF_Tc` \ (theta:thetas) -> + checkTc (all (eqSimpleTheta theta) thetas) + (sigContextsErr tc_ty_sigs) `thenTc_` + + returnTc theta + where + check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc) + = tcAddSrcLoc src_loc $ + tcAddErrCtxt (sigCtxt id) $ + unifyTauTy sig_tau mono_id_ty `thenTc_` + checkSigTyVars sig_tyvars sig_tau + where + mono_id_ty = idType (assoc "checkSigMatch" binder_names_w_mono_ids name) + + get_zonked_theta (TySigInfo _ _ _ theta _ _) + = mapNF_Tc (\ (c,t) -> zonkTcType t `thenNF_Tc` \ t' -> returnNF_Tc (c,t')) theta +\end{code} + + +@checkSigTyVars@ is used after the type in a type signature has been unified with +the actual type found. It then checks that the type variables of the type signature +are + (a) still all type variables + eg matching signature [a] against inferred type [(p,q)] + [then a will be unified to a non-type variable] + + (b) still all distinct + eg matching signature [(a,b)] against inferred type [(p,p)] + [then a and b will be unified together] + +BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS + + (c) not mentioned in the environment + eg the signature for f in this: + + g x = ... where + f :: a->[a] + f y = [x,y] + + Here, f is forced to be monorphic by the free occurence of x. + +Before doing this, the substitution is applied to the signature type variable. + +\begin{code} +checkSigTyVars :: [TcTyVar s] -- The original signature type variables + -> TcType s -- signature type (for err msg) + -> TcM s () + +checkSigTyVars sig_tyvars sig_tau + = tcGetGlobalTyVars `thenNF_Tc` \ globals -> + let + mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars + in + -- TEMPORARY FIX + -- Until the final Bind-handling stuff is in, several type signatures in the same + -- bindings group can cause the signature type variable from the different + -- signatures to be unified. So we still need to zonk and check point (b). + -- Remove when activating the new binding code + mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys -> + checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys)) + (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> + failTc (badMatchErr sig_tau sig_tau') + ) `thenTc_` + + + -- Check point (c) + -- We want to report errors in terms of the original signature tyvars, + -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond + -- 1-1 with sig_tyvars, so we can just map back. + checkTc (null mono_tyvars) + (notAsPolyAsSigErr sig_tau mono_tyvars) \end{code} @@ -653,57 +804,72 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) %************************************************************************ %* * -\subsection[TcBinds-monomorphism]{The monomorphism restriction} +\subsection[TcBinds-errors]{Error contexts and messages} %* * %************************************************************************ -Not exported: \begin{code} -{- In GenSpec at the moment +patMonoBindsCtxt bind sty + = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind) -isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these - -> TcBind s - -> Bool +----------------------------------------------- +valSpecSigCtxt v ty sty + = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:")) + 4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")), + ppr sty ty]) -isUnRestrictedGroup sigs EmptyBind = True -isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds -isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds -is_elem v vs = isIn "isUnResMono" v vs -isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs -isUnResMono sigs (PatMonoBind other _ _) = False -isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs -isUnResMono sigs (FunMonoBind _ _ _ _) = True -isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && - isUnResMono sigs mb2 -isUnResMono sigs EmptyMonoBinds = True --} -\end{code} +----------------------------------------------- +notAsPolyAsSigErr sig_tau mono_tyvars sty + = ppHang (ppPStr SLIT("A type signature is more polymorphic than the inferred type")) + 4 (ppAboves [ppStr "Some type variables in the inferred type can't be forall'd, namely:", + interpp'SP sty mono_tyvars, + ppPStr SLIT("Possible cause: the RHS mentions something subject to the monomorphism restriction") + ]) +----------------------------------------------- +badMatchErr sig_ty inferred_ty sty + = ppHang (ppPStr SLIT("Type signature doesn't match inferred type")) + 4 (ppAboves [ppHang (ppPStr SLIT("Signature:")) 4 (ppr sty sig_ty), + ppHang (ppPStr SLIT("Inferred :")) 4 (ppr sty inferred_ty) + ]) -%************************************************************************ -%* * -\subsection[TcBinds-errors]{Error contexts and messages} -%* * -%************************************************************************ +----------------------------------------------- +sigCtxt id sty + = ppSep [ppPStr SLIT("When checking signature for"), ppr sty id] +sigsCtxt ids sty + = ppSep [ppPStr SLIT("When checking signature(s) for:"), interpp'SP sty ids] +----------------------------------------------- +sigContextsErr ty_sigs sty + = ppHang (ppPStr SLIT("A group of type signatures have mismatched contexts")) + 4 (ppAboves (map ppr_tc_ty_sig ty_sigs)) + where + ppr_tc_ty_sig (TySigInfo val _ tyvars theta tau_ty _) + = ppHang (ppBeside (ppr sty val) (ppPStr SLIT(" :: "))) + 4 (if null theta + then ppNil + else ppBesides [ppChar '(', + ppIntersperse (ppStr ", ") (map (ppr_inst sty) theta), + ppStr ") => ..."]) + ppr_inst sty (clas, ty) = ppCat [ppr sty clas, ppr sty ty] -\begin{code} -patMonoBindsCtxt bind sty - = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind) +----------------------------------------------- +specGroundnessCtxt + = panic "specGroundnessCtxt" -------------------------------------------- specContextGroundnessCtxt -- err_ctxt dicts sty = panic "specContextGroundnessCtxt" {- = ppHang ( - ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"], - ppBesides [ppStr " specialised to the type `", ppr sty spec_ty, ppStr "'"], + ppSep [ppBesides [ppPStr SLIT("In the SPECIALIZE pragma for `"), ppr sty name, ppChar '\''], + ppBesides [ppPStr SLIT(" specialised to the type `"), ppr sty spec_ty, ppChar '\''], pp_spec_id sty, - ppStr "... not all overloaded type variables were instantiated", - ppStr "to ground types:"]) + ppPStr SLIT("... not all overloaded type variables were instantiated"), + ppPStr SLIT("to ground types:")]) 4 (ppAboves [ppCat [ppr sty c, ppr sty t] | (c,t) <- map getDictClassAndType dicts]) where @@ -712,17 +878,10 @@ specContextGroundnessCtxt -- err_ctxt dicts sty ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> ppNil) ValSpecSpecIdCtxt n ty spec loc -> (n, ty, loc, - \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"]) + \ sty -> ppBesides [ppPStr SLIT("... type of explicit id `"), ppr sty spec, ppChar '\'']) -} +\end{code} ------------------------------------------------ -specGroundnessCtxt - = panic "specGroundnessCtxt" -valSpecSigCtxt v ty sty - = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:")) - 4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")), - ppr sty ty]) -\end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index da8ea9562c..c28bce15cc 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -14,7 +14,7 @@ import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity, HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, - Stmt, Qualifier, ArithSeqInfo, InPat, Fake ) + Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake ) import HsTypes ( getTyVarName ) import HsPragmas ( ClassPragmas(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), @@ -25,7 +25,8 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(Tc mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod ) -import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars ) +import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo, + tcExtendGlobalTyVars ) import TcInstDcls ( processInstBinds ) import TcKind ( unifyKind, TcKind ) import TcMonad @@ -204,9 +205,9 @@ tcClassSig :: Class -- Knot tying only! Id) -- default-method ids tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn - (ClassOpSig op_name + (ClassOpSig op_name dm_name op_ty - pragmas src_loc) + src_loc) = tcAddSrcLoc src_loc $ fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas @@ -227,13 +228,13 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn in -- Build the selector id and default method id - tcGetUnique `thenNF_Tc` \ d_uniq -> let - sel_id = mkMethodSelId op_name rec_clas class_op global_ty - defm_id = mkDefaultMethodId op_name d_uniq rec_clas class_op False global_ty + sel_id = mkMethodSelId op_name rec_clas class_op global_ty + defm_id = mkDefaultMethodId dm_name rec_clas class_op False global_ty -- ToDo: improve the "False" in - returnTc (class_op, sel_id, defm_id) + tcAddImportedIdInfo defm_id `thenNF_Tc` \ final_defm_id -> + returnTc (class_op, sel_id, final_defm_id) ) \end{code} @@ -431,6 +432,72 @@ buildDefaultMethodBinds clas clas_tyvar origin = ClassDeclOrigin \end{code} +==================== +buildDefaultMethodBinds + :: Class + -> TcTyVar s + -> [Id] + -> RenamedMonoBinds + -> TcM s (LIE s, TcHsBinds s) + +buildDefaultMethodBinds clas clas_tyvar + default_method_ids default_binds + = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + tcExtendGlobalTyVars clas_tyvar_set ( + tcDefaultMethodBinds default_binds + ) + +tcDefaultMethodBinds default_meth_ids default_binds + where + go (AndMonoBinds b1 b2) + = go b1 `thenTc` \ (new_b1, lie1) -> + go b2 `thenTc` \ (new_b2, lie2) -> + returnTc (new_b1 `ThenBinds` new_b2, lie1 `plusLIE` lie2) + + go EmptyMonoBinds = EmptyBinds + + go mbind = processInstBinds1 clas clas_dict meth_ids mbind `thenTc` \ (tags + +tcDefaultMethodBinds EmptyMonoBinds + + + + processInstBinds + clas + (makeClassDeclDefaultMethodRhs clas local_defm_ids) + avail_insts + local_defm_ids + default_binds + ) `thenTc` \ (insts_needed, default_binds') -> + + let + mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) -> + let + avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available + clas_tyvar_set = unitTyVarSet clas_tyvar + in + + tcSimplifyAndCheck + clas_tyvar_set + avail_insts + insts_needed `thenTc` \ (const_lie, dict_binds) -> + + + let + defm_binds = AbsBinds + [clas_tyvar] + [this_dict_id] + (local_defm_ids `zip` map RealId default_method_ids) + dict_binds + (RecBind default_binds') + in + returnTc (const_lie, defm_binds) + where + inst_ty = mkTyVarTy clas_tyvar + mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty] + origin = ClassDeclOrigin +================== + @makeClassDeclDefaultMethodRhs@ builds the default method for a class declaration when no explicit default method is given. @@ -466,5 +533,5 @@ Contexts ~~~~~~~~ \begin{code} classDeclCtxt class_name sty - = ppCat [ppStr "In the class declaration for", ppr sty class_name] + = ppCat [ppPStr SLIT("In the class declaration for"), ppr sty class_name] \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index bb0557d4b6..b12cb5f7e4 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -25,7 +25,7 @@ import TcSimplify ( tcSimplifyCheckThetas ) import TysWiredIn ( intTy, doubleTy, unitTy ) import Unique ( numClassKey ) -import Pretty ( ppStr, ppAboves ) +import Pretty ( ppPStr, ppAboves ) import ErrUtils ( addShortErrLocLine ) import Util \end{code} @@ -67,10 +67,10 @@ dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty where item1 = addShortErrLocLine locn1 (\ sty -> - ppStr "multiple default declarations") sty + ppPStr SLIT("multiple default declarations")) sty dup_item (DefaultDecl _ locn) = addShortErrLocLine locn (\ sty -> - ppStr "here was another default declaration") sty + ppPStr SLIT("here was another default declaration")) sty \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 079bd72d3e..d9f0b626be 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -49,7 +49,8 @@ import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance, import Outputable ( Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) import PprStyle ( PprStyle(..) ) -import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) ) +import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, + ppPStr, ppStr, ppChar, ppHang, SYN_IE(Pretty) ) --import Pretty--ToDo:rm --import FiniteMap--ToDo:rm import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) @@ -242,8 +243,8 @@ tcDeriving modname rn_name_supply inst_decl_infos_in mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds -> returnRn (dfun_names_w_method_binds, rn_extra_binds) ) - rn_one meth_binds = newDfunName mkGeneratedSrcLoc `thenRn` \ dfun_name -> - rnMethodBinds meth_binds `thenRn` \ rn_meth_binds -> + rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name -> + rnMethodBinds meth_binds `thenRn` \ rn_meth_binds -> returnRn (dfun_name, rn_meth_binds) in @@ -716,6 +717,6 @@ gen_taggery_Names inst_infos derivingThingErr :: String -> TyCon -> Error derivingThingErr thing tycon sty - = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing]) - 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"]) + = ppHang (ppCat [ppPStr SLIT("Can't make a derived instance of"), ppStr thing]) + 4 (ppBesides [ppPStr SLIT("for the type `"), ppr sty tycon, ppChar '\'']) \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 473ce91be4..9bf814d05b 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -15,6 +15,7 @@ module TcEnv( tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe, + tcAddImportedIdInfo, tcLookupGlobalValueByKeyMaybe, newMonoIds, newLocalIds, newLocalId, @@ -26,7 +27,7 @@ IMP_Ubiq() IMPORT_DELOOPER(TcMLoop) -- for paranoia checking import HsTypes ( HsTyVar(..) ) -import Id ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId ) +import Id ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo ) import PragmaInfo ( PragmaInfo(..) ) import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) ) import TcKind ( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind ) @@ -40,6 +41,7 @@ import Class ( SYN_IE(Class), GenClass, classSig ) import TcMonad +import IdInfo ( noIdInfo ) import Name ( Name, OccName(..), getSrcLoc, occNameString, maybeWiredInTyConName, maybeWiredInIdName, pprSym ) @@ -280,6 +282,19 @@ tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id) tcLookupGlobalValueByKeyMaybe uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM_Directly gve uniq) + + -- Extract the IdInfo from an IfaceSig imported from an interface file +tcAddImportedIdInfo :: Id -> NF_TcM s Id +tcAddImportedIdInfo id + = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id -> + let + new_info = case maybe_id of + Nothing -> noIdInfo + Just imported_id -> getIdInfo imported_id + -- ToDo: could check that types are the same + in + returnNF_Tc (id `replaceIdInfo` new_info) + -- The Id must be returned without a data dependency on maybe_id \end{code} @@ -319,8 +334,8 @@ newLocalIds names tys \begin{code} classAsTyConErr name sty - = ppBesides [ppStr "Class used as a type constructor: ", pprSym sty name] + = ppBesides [ppPStr SLIT("Class used as a type constructor: "), pprSym sty name] tyConAsClassErr name sty - = ppBesides [ppStr "Type constructor used as a class: ", pprSym sty name] + = ppBesides [ppPStr SLIT("Type constructor used as a class: "), pprSym sty name] \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 65738ee6f9..2d46c8bedb 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -10,15 +10,15 @@ module TcExpr ( tcExpr, tcId ) where IMP_Ubiq() -import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..), +import HsSyn ( HsExpr(..), Stmt(..), DoOrListComp(..), HsBinds(..), Bind(..), MonoBinds(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, Match, Fake, InPat, OutPat, HsType, Fixity, pprParendExpr, failureFreePat, collectPatBinders ) -import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual), +import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds) ) -import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt), +import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcStmt), TcIdOcc(..), SYN_IE(TcRecordBinds), mkHsTyApp ) @@ -27,7 +27,7 @@ import TcMonad import Inst ( Inst, InstOrigin(..), OverloadedLit(..), SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcBindsAndThen, checkSigTyVars ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, tcExtendGlobalTyVars @@ -47,7 +47,6 @@ import Class ( SYN_IE(Class), classSig ) import FieldLabel ( fieldLabelName ) import Id ( idType, dataConFieldLabels, dataConSig, SYN_IE(Id), GenId ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) -import GenSpecEtc ( checkSigTyVars ) import Name ( Name{-instance Eq-} ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, getTyVar_maybe, getFunTy_maybe, instantiateTy, @@ -67,7 +66,7 @@ import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, - thenMClassOpKey, zeroClassOpKey + thenMClassOpKey, zeroClassOpKey, returnMClassOpKey ) import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances @@ -314,15 +313,11 @@ tcExpr (HsIf pred b1 b2 src_loc) unifyTauTy result_ty b2Ty `thenTc_` returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty) - -tcExpr (ListComp expr quals) - = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) -> - returnTc (ListComp expr' quals', lie, ty) \end{code} \begin{code} -tcExpr expr@(HsDo stmts src_loc) - = tcDoStmts stmts src_loc +tcExpr expr@(HsDo do_or_lc stmts src_loc) + = tcDoStmts do_or_lc stmts src_loc \end{code} \begin{code} @@ -671,72 +666,12 @@ tcId name %************************************************************************ %* * -\subsection{@tcQuals@ typechecks list-comprehension qualifiers} -%* * -%************************************************************************ - -\begin{code} -tcListComp expr [] - = tcExpr expr `thenTc` \ (expr', lie, ty) -> - returnTc ((expr',[]), lie, mkListTy ty) - -tcListComp expr (qual@(FilterQual filter) : quals) - = tcAddErrCtxt (qualCtxt qual) ( - tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) -> - unifyTauTy boolTy filter_ty `thenTc_` - returnTc (FilterQual filter', filter_lie) - ) `thenTc` \ (qual', qual_lie) -> - - tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) -> - - returnTc ((expr', qual' : quals'), - qual_lie `plusLIE` rest_lie, - res_ty) - -tcListComp expr (qual@(GeneratorQual pat rhs) : quals) - = newMonoIds binder_names mkBoxedTypeKind (\ ids -> - - tcAddErrCtxt (qualCtxt qual) ( - tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) -> - tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) -> - -- NB: the environment has been extended with the new binders - -- which the rhs can't "see", but the renamer should have made - -- sure that everything is distinct by now, so there's no problem. - -- Putting the tcExpr before the newMonoIds messes up the nesting - -- of error contexts, so I didn't bother - - unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_` - returnTc (GeneratorQual pat' rhs', - lie_pat `plusLIE` lie_rhs) - ) `thenTc` \ (qual', lie_qual) -> - - tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) -> - - returnTc ((expr', qual' : quals'), - lie_qual `plusLIE` lie_rest, - res_ty) - ) - where - binder_names = collectPatBinders pat - -tcListComp expr (LetQual binds : quals) - = tcBindsAndThen -- No error context, but a binding group is - combine -- rather a large thing for an error context anyway - binds - (tcListComp expr quals) - where - combine binds' (expr',quals') = (expr', LetQual binds' : quals') -\end{code} - - -%************************************************************************ -%* * \subsection{@tcDoStmts@ typechecks a {\em list} of do statements} %* * %************************************************************************ \begin{code} -tcDoStmts stmts src_loc +tcDoStmts do_or_lc stmts src_loc = -- get the Monad and MonadZero classes -- create type consisting of a fresh monad tyvar tcAddSrcLoc src_loc $ @@ -744,55 +679,80 @@ tcDoStmts stmts src_loc -- Build the then and zero methods in case we need them + tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id -> tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id -> tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id -> newMethod DoOrigin - (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) -> + (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) -> + newMethod DoOrigin + (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) -> newMethod DoOrigin - (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) -> + (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) -> let - get_m_arg ty - = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty -> - unifyTauTy (mkAppTy m arg_ty) ty `thenTc_` - returnTc arg_ty - - go [stmt@(ExprStmt exp src_loc)] - = tcAddSrcLoc src_loc $ - tcSetErrCtxt (stmtCtxt stmt) $ - tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty) + -- go :: [RenamedStmt] -> TcM s ([TcStmt s], LIE s, TcType s) + go [stmt@(ReturnStmt exp)] -- Must be last statement + = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } ) + tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> + returnTc ([ReturnStmt exp'], return_lie `plusLIE` exp_lie, mkAppTy m exp_ty) + + go (stmt@(GuardStmt exp src_loc) : stmts) + = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } ) + tcAddSrcLoc src_loc ( + tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> + unifyTauTy boolTy exp_ty `thenTc_` + returnTc (GuardStmt exp' src_loc, exp_lie) + )) `thenTc` \ (stmt', stmt_lie) -> + go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> + returnTc (stmt' : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` zero_lie, + stmts_ty) + go (stmt@(ExprStmt exp src_loc) : stmts) - = tcAddSrcLoc src_loc ( - tcSetErrCtxt (stmtCtxt stmt) ( + = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } ) + tcAddSrcLoc src_loc ( + tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - get_m_arg exp_ty `thenTc` \ a -> - returnTc (a, exp', exp_lie) - )) `thenTc` \ (a, exp', exp_lie) -> + -- Check that exp has type (m tau) for some tau (doesn't matter what) + newTyVarTy mkTypeKind `thenNF_Tc` \ tau -> + unifyTauTy (mkAppTy m tau) exp_ty `thenTc_` + returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty, exp_ty) + )) `thenTc` \ (stmt', stmt_lie, stmt_ty, result_ty) -> + if null stmts then + -- This is the last statement + returnTc ([stmt'], stmt_lie, result_ty) + else + -- More statments follow go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> - get_m_arg stmts_ty `thenTc` \ b -> - returnTc (ExprStmtOut exp' src_loc a b : stmts', - exp_lie `plusLIE` stmts_lie `plusLIE` m_lie, + returnTc (stmt' : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` then_lie, stmts_ty) go (stmt@(BindStmt pat exp src_loc) : stmts) = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ -> tcAddSrcLoc src_loc ( - tcSetErrCtxt (stmtCtxt stmt) ( + tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) -> tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - -- See comments with tcListComp on GeneratorQual + unifyTauTy (mkAppTy m pat_ty) exp_ty `thenTc_` + + -- NB: the environment has been extended with the new binders + -- which the rhs can't "see", but the renamer should have made + -- sure that everything is distinct by now, so there's no problem. + -- Putting the tcExpr before the newMonoIds messes up the nesting + -- of error contexts, so I didn't bother + + returnTc (BindStmt pat' exp' src_loc, pat', pat_lie `plusLIE` exp_lie) + )) `thenTc` \ (stmt', pat', stmt_lie) -> - get_m_arg exp_ty `thenTc` \ a -> - unifyTauTy pat_ty a `thenTc_` - returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie) - )) `thenTc` \ (a, pat', exp', stmt_lie) -> go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> - get_m_arg stmts_ty `thenTc` \ b -> - returnTc (BindStmtOut pat' exp' src_loc a b : stmts', - stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE` - (if failureFreePat pat' then emptyLIE else mz_lie), + + returnTc (stmt' : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` then_lie `plusLIE` + (if failureFreePat pat' then emptyLIE else zero_lie), stmts_ty) go (LetStmt binds : stmts) @@ -804,12 +764,18 @@ tcDoStmts stmts src_loc combine binds' stmts' = LetStmt binds' : stmts' in - go stmts `thenTc` \ (stmts', final_lie, final_ty) -> - returnTc (HsDoOut stmts' then_id zero_id src_loc, + go stmts `thenTc` \ (stmts', final_lie, result_ty) -> + returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id result_ty src_loc, final_lie, - final_ty) + result_ty) \end{code} +%************************************************************************ +%* * +\subsection{Record bindings} +%* * +%************************************************************************ + Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For each binding @@ -901,70 +867,70 @@ pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff) Boring and alphabetical: \begin{code} arithSeqCtxt expr sty - = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In an arithmetic sequence:")) 4 (ppr sty expr) branchCtxt b1 b2 sty - = ppSep [ppStr "In the branches of a conditional:", + = ppSep [ppPStr SLIT("In the branches of a conditional:"), pp_nest_hang "`then' branch:" (ppr sty b1), pp_nest_hang "`else' branch:" (ppr sty b2)] caseCtxt expr sty - = ppHang (ppStr "In a case expression:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a case expression:")) 4 (ppr sty expr) exprSigCtxt expr sty - = ppHang (ppStr "In an expression with a type signature:") + = ppHang (ppPStr SLIT("In an expression with a type signature:")) 4 (ppr sty expr) listCtxt expr sty - = ppHang (ppStr "In a list expression:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a list expression:")) 4 (ppr sty expr) predCtxt expr sty - = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a predicate expression:")) 4 (ppr sty expr) sectionRAppCtxt expr sty - = ppHang (ppStr "In a right section:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a right section:")) 4 (ppr sty expr) sectionLAppCtxt expr sty - = ppHang (ppStr "In a left section:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a left section:")) 4 (ppr sty expr) funAppCtxt fun arg_no arg sty - = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", + = ppHang (ppCat [ ppPStr SLIT("In the"), speakNth arg_no, ppPStr SLIT("argument of"), ppr sty fun `ppBeside` ppStr ", namely"]) 4 (pprParendExpr sty arg) -qualCtxt qual sty - = ppHang (ppStr "In a list-comprehension qualifer:") - 4 (ppr sty qual) +stmtCtxt ListComp stmt sty + = ppHang (ppPStr SLIT("In a list-comprehension qualifer:")) + 4 (ppr sty stmt) -stmtCtxt stmt sty - = ppHang (ppStr "In a do statement:") +stmtCtxt DoStmt stmt sty + = ppHang (ppPStr SLIT("In a do statement:")) 4 (ppr sty stmt) tooManyArgsCtxt f sty - = ppHang (ppStr "Too many arguments in an application of the function") + = ppHang (ppPStr SLIT("Too many arguments in an application of the function")) 4 (ppr sty f) lurkingRank2Err fun fun_ty sty - = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun]) + = ppHang (ppCat [ppPStr SLIT("Illegal use of"), ppr sty fun]) 4 (ppAboves [ppStr "It is applied to too few arguments,", - ppStr "so that the result type has for-alls in it"]) + ppPStr SLIT("so that the result type has for-alls in it")]) rank2ArgCtxt arg expected_arg_ty sty - = ppHang (ppStr "In a polymorphic function argument:") - 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"), + = ppHang (ppPStr SLIT("In a polymorphic function argument:")) + 4 (ppSep [ppBeside (ppr sty arg) (ppPStr SLIT(" ::")), ppr sty expected_arg_ty]) badFieldsUpd rbinds sty - = ppHang (ppStr "No constructor has all these fields:") + = ppHang (ppPStr SLIT("No constructor has all these fields:")) 4 (interpp'SP sty fields) where fields = [field | (field, _, _) <- rbinds] -recordUpdCtxt sty = ppStr "In a record update construct" +recordUpdCtxt sty = ppPStr SLIT("In a record update construct") badFieldsCon con rbinds sty - = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con]) - 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields]) + = ppHang (ppBesides [ppPStr SLIT("Inconsistent constructor:"), ppr sty con]) + 4 (ppBesides [ppPStr SLIT("and fields:"), interpp'SP sty fields]) where fields = [field | (field, _, _) <- rbinds] \end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 856ad7c0a5..e589426935 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -31,7 +31,7 @@ IMP_Ubiq() IMPORT_1_3(List(partition)) import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), - GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt, + GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..), ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake ) import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp, SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) @@ -304,7 +304,8 @@ gen_Ord_binds tycon = partition isNullaryDataCon (tyConDataCons tycon) cmp_eq - = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ deflt_pats_etc) + = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ + [([WildPatIn, WildPatIn], default_rhs)]) where pats_etc data_con = ([con1_pat, con2_pat], @@ -326,10 +327,10 @@ gen_Ord_binds tycon = let eq_expr = nested_compare_expr tys as bs in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b) - deflt_pats_etc - = if null nullary_cons - then [] - else [([a_Pat, b_Pat], eqTag_Expr)] + default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about + -- inexhaustive patterns + | otherwise = eqTag_Expr -- Some nullary constructors; + -- Tags are equal, no args => return EQ -------------------------------------------------------------------- defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] @@ -597,12 +598,16 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range - = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] ( - ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed) - ) + = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $ + HsDo ListComp stmts tycon_loc where - mk_qual a b c = GeneratorQual (VarPatIn c) - (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b])) + stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed + ++ + [ReturnStmt (con_expr cs_needed)] + + mk_qual a b c = BindStmt (VarPatIn c) + (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b])) + tycon_loc ---------------- single_con_index @@ -673,11 +678,26 @@ gen_Read_binds tycon nullary_con = isNullaryDataCon data_con con_qual - = GeneratorQual + = BindStmt (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat]) (HsApp (HsVar lex_RDR) c_Expr) + tycon_loc field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed)) + mk_qual draw_from (con_field, str_left) + = (HsVar str_left, -- what to draw from down the line... + BindStmt + (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) + (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from) + tycon_loc + ) + + result_expr = ExplicitTuple [con_expr, if null bs_needed + then d_Expr + else HsVar (last bs_needed)] + + stmts = (con_qual : field_quals) ++ [ReturnStmt result_expr] + read_paren_arg = if nullary_con then -- must be False (parens are surely optional) @@ -687,17 +707,9 @@ gen_Read_binds tycon in HsApp ( readParen_Expr read_paren_arg $ HsPar $ - HsLam (mk_easy_Match tycon_loc [c_Pat] [] ( - ListComp (ExplicitTuple [con_expr, - if null bs_needed then d_Expr else HsVar (last bs_needed)]) - (con_qual : field_quals))) + HsLam (mk_easy_Match tycon_loc [c_Pat] [] $ + HsDo ListComp stmts tycon_loc) ) (HsVar b_RDR) - where - mk_qual draw_from (con_field, str_left) - = (HsVar str_left, -- what to draw from down the line... - GeneratorQual - (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) - (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)) \end{code} %************************************************************************ @@ -795,7 +807,8 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) var_RDR = qual_orig_name var gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) - = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon)) + = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++ + [([WildPatIn], impossible_Expr)]) where mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) @@ -812,6 +825,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) + \end{code} %************************************************************************ @@ -1006,6 +1020,10 @@ nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es) +-- impossible_Expr is used in case RHSs that should never happen. +-- We generate these to keep the desugarer from complaining that they *might* happen! +impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv"))) + parenify e@(HsVar _) = e parenify e = HsPar e diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index a1662a025c..66fe9cedc9 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -14,13 +14,13 @@ module TcHsSyn ( SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat), SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch), - SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), + SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo), - SYN_IE(TypecheckedQual), SYN_IE(TypecheckedStmt), + SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule), SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), SYN_IE(TypecheckedRecordBinds), @@ -87,7 +87,6 @@ type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcQual s = Qualifier (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) @@ -101,7 +100,6 @@ type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedQual = Qualifier TyVar UVar Id TypecheckedPat type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat @@ -408,16 +406,16 @@ zonkExpr te ve (HsLet binds expr) zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo" +zonkExpr te ve (HsDo _ _ _) = panic "zonkExpr te ve:HsDo" -zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc) +zonkExpr te ve (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) = zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc) - -zonkExpr te ve (ListComp expr quals) - = zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) -> - zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (ListComp new_expr new_quals) + zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (HsDoOut do_or_lc new_stmts + (zonkIdOcc ve return_id) + (zonkIdOcc ve then_id) + (zonkIdOcc ve zero_id) + new_ty src_loc) zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList" @@ -531,63 +529,38 @@ zonkArithSeq te ve (FromThenTo e1 e2 e3) returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkQuals :: TyVarEnv Type -> IdEnv Id - -> [TcQual s] -> NF_TcM s ([TypecheckedQual], IdEnv Id) - -zonkQuals te ve [] - = returnNF_Tc ([], ve) - -zonkQuals te ve (GeneratorQual pat expr : quals) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - let - new_ve = extend_ve ve ids - in - zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) -> - returnNF_Tc (GeneratorQual new_pat new_expr : new_quals, final_ve) - -zonkQuals te ve (FilterQual expr : quals) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkQuals te ve quals `thenNF_Tc` \ (new_quals, final_ve) -> - returnNF_Tc (FilterQual new_expr : new_quals, final_ve) - -zonkQuals te ve (LetQual binds : quals) - = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> - zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) -> - returnNF_Tc (LetQual new_binds : new_quals, final_ve) - -------------------------------------------------------------------------- zonkStmts :: TyVarEnv Type -> IdEnv Id -> [TcStmt s] -> NF_TcM s [TypecheckedStmt] zonkStmts te ve [] = returnNF_Tc [] -zonkStmts te ve [ExprStmt expr locn] +zonkStmts te ve [ReturnStmt expr] + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc [ReturnStmt new_expr] + +zonkStmts te ve (ExprStmt expr locn : stmts) = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc [ExprStmt new_expr locn] + zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ExprStmt new_expr locn : new_stmts) -zonkStmts te ve (ExprStmtOut expr locn a b : stmts) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType te a `thenNF_Tc` \ new_a -> - zonkTcTypeToType te b `thenNF_Tc` \ new_b -> +zonkStmts te ve (GuardStmt expr locn : stmts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : new_stmts) + returnNF_Tc (GuardStmt new_expr locn : new_stmts) zonkStmts te ve (LetStmt binds : stmts) = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> returnNF_Tc (LetStmt new_binds : new_stmts) -zonkStmts te ve (BindStmtOut pat expr locn a b : stmts) +zonkStmts te ve (BindStmt pat expr locn : stmts) = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType te a `thenNF_Tc` \ new_a -> - zonkTcTypeToType te b `thenNF_Tc` \ new_b -> let new_ve = extend_ve ve ids in zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts) + returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts) @@ -668,6 +641,13 @@ zonkPat te ve (NPat lit ty expr) zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (NPat lit new_ty new_expr, []) +zonkPat te ve (NPlusKPat n k ty e1 e2) + = zonkIdBndr te n `thenNF_Tc` \ new_n -> + zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, [new_n]) + zonkPat te ve (DictPat ds ms) = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds -> mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms -> diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 47b3e77298..9a131e90d7 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -24,14 +24,15 @@ import HsCore import HsDecls ( HsIdInfo(..) ) import Literal ( Literal(..) ) import CoreSyn +import CoreUtils ( coreExprType ) import CoreUnfold import MagicUFs ( MagicUnfoldingFun ) import WwLib ( mkWrapper ) import SpecEnv ( SpecEnv ) import PrimOp ( PrimOp(..) ) -import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe ) -import Type ( mkSynTy ) +import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe, dataConArgTys ) +import Type ( mkSynTy, getAppDataTyConExpandingDicts ) import TyVar ( mkTyVar ) import Name ( Name ) import Unique ( rationalTyConKey ) @@ -164,7 +165,7 @@ tcVar name Nothing -> failTc (noDecl name) } -noDecl name sty = ppCat [ppStr "Warning: no binding for", ppr sty name] +noDecl name sty = ppCat [ppPStr SLIT("Warning: no binding for"), ppr sty name] \end{code} UfCore expressions. @@ -208,8 +209,8 @@ tcCoreExpr (UfApp fun arg) returnTc (App fun' arg') tcCoreExpr (UfCase scrut alts) - = tcCoreExpr scrut `thenTc` \ scrut' -> - tcCoreAlts alts `thenTc` \ alts' -> + = tcCoreExpr scrut `thenTc` \ scrut' -> + tcCoreAlts (coreExprType scrut') alts `thenTc` \ alts' -> returnTc (Case scrut' alts') tcCoreExpr (UfSCC cc expr) @@ -264,7 +265,7 @@ tcCoreLamBndr (UfUsageBinder name) thing_inside tcCoreValBndr (UfValBinder name ty) thing_inside = tcHsType ty `thenTc` \ ty' -> let - id = mkUserId name ty' NoPragmaInfo + id = mk_id name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -273,13 +274,14 @@ tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders = mapTc tcHsType tys `thenTc` \ tys' -> let ids = zipWithEqual "tcCoreValBndr" mk_id names tys' - mk_id name ty' = mkUserId name ty' NoPragmaInfo in tcExtendGlobalValEnv ids $ thing_inside ids where names = map (\ (UfValBinder name _) -> name) bndrs tys = map (\ (UfValBinder _ ty) -> ty) bndrs + +mk_id name ty = mkUserId name ty NoPragmaInfo \end{code} \begin{code} @@ -288,28 +290,39 @@ tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg tcCoreArg (UfLitArg lit) = returnTc (LitArg lit) tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage" -tcCoreAlts (UfAlgAlts alts deflt) - = mapTc tc_alt alts `thenTc` \ alts' -> - tcCoreDefault deflt `thenTc` \ deflt' -> +tcCoreAlts scrut_ty (UfAlgAlts alts deflt) + = mapTc tc_alt alts `thenTc` \ alts' -> + tcCoreDefault scrut_ty deflt `thenTc` \ deflt' -> returnTc (AlgAlts alts' deflt') where - tc_alt (con, bndrs, rhs) = tcVar con `thenTc` \ con' -> - tcCoreValBndrs bndrs $ \ bndrs' -> - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (con', bndrs', rhs') - -tcCoreAlts (UfPrimAlts alts deflt) - = mapTc tc_alt alts `thenTc` \ alts' -> - tcCoreDefault deflt `thenTc` \ deflt' -> + tc_alt (con, names, rhs) + = tcVar con `thenTc` \ con' -> + let + arg_tys = dataConArgTys con' inst_tys + (tycon, inst_tys, cons) = getAppDataTyConExpandingDicts scrut_ty + arg_ids = zipWithEqual "tcCoreAlts" mk_id names arg_tys + in + tcExtendGlobalValEnv arg_ids $ + tcCoreExpr rhs `thenTc` \ rhs' -> + returnTc (con', arg_ids, rhs') + +tcCoreAlts scrut_ty (UfPrimAlts alts deflt) + = mapTc tc_alt alts `thenTc` \ alts' -> + tcCoreDefault scrut_ty deflt `thenTc` \ deflt' -> returnTc (PrimAlts alts' deflt') where tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (lit, rhs') -tcCoreDefault UfNoDefault = returnTc NoDefault -tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr $ \ bndr' -> - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (BindDefault bndr' rhs') +tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault +tcCoreDefault scrut_ty (UfBindDefault name rhs) + = let + deflt_id = mk_id name scrut_ty + in + tcExtendGlobalValEnv [deflt_id] $ + tcCoreExpr rhs `thenTc` \ rhs' -> + returnTc (BindDefault deflt_id rhs') + tcCoercion (UfIn n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn n') tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n') diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index c129ae5cf7..96177adefa 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -20,7 +20,7 @@ import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl, SpecInstSig(..), HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Stmt, Qualifier, ArithSeqInfo, Fake, Fixity, + Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity, HsType(..), HsTyVar ) import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), @@ -34,10 +34,9 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), import TcMonad import RnMonad ( SYN_IE(RnNameSupply) ) -import GenSpecEtc ( checkSigTyVars ) import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE ) -import TcBinds ( tcPragmaSigs ) +import TcBinds ( tcPragmaSigs, checkSigTyVars ) import TcDeriv ( tcDeriving ) import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars ) import SpecEnv ( SpecEnv ) @@ -77,7 +76,7 @@ import SrcLoc ( SrcLoc ) import Pretty import TyCon ( isSynTyCon, derivedFor ) import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType, - splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, + splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy, getTyCon_maybe, maybeAppTyCon, maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy ) @@ -455,7 +454,7 @@ makeInstanceDeclDefaultMethodExpr src_loc clas meth_ids defm_ids inst_ty this_di Just (_, _, defm_is_err) = isDefaultMethodId_maybe defm_id - error_msg = ppShow 80 (ppSep [ppr PprForUser clas_op, ppStr "at", ppr PprForUser src_loc]) + error_msg = ppShow 80 (ppSep [ppr PprForUser clas_op, ppPStr SLIT("at"), ppr PprForUser src_loc]) clas_op = (classOps clas) !! idx clas_name = getOccString clas @@ -751,12 +750,12 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc (if sw_chkr SpecialiseTrace then pprTrace "Specialised Instance: " (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta, - if null simpl_theta then ppNil else ppStr "=>", + if null simpl_theta then ppNil else ppPStr SLIT("=>"), ppr PprDebug clas, pprParendGenType PprDebug inst_ty], - ppCat [ppStr " derived from:", + ppCat [ppPStr SLIT(" derived from:"), if null unspec_theta then ppNil else ppr PprDebug unspec_theta, - if null unspec_theta then ppNil else ppStr "=>", + if null unspec_theta then ppNil else ppPStr SLIT("=>"), ppr PprDebug clas, pprParendGenType PprDebug unspec_inst_ty]]) else id) ( @@ -843,7 +842,7 @@ scrutiniseInstanceType dfun_name clas inst_tau = returnTc (inst_tycon,arg_tys) where - (possible_tycon, arg_tys) = splitAppTy inst_tau + (possible_tycon, arg_tys) = splitAppTys inst_tau inst_tycon_maybe = getTyCon_maybe possible_tycon inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe @@ -885,51 +884,56 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) || instTypeErr ty sty = case ty of - SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg] - TyVarTy tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg] - other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg] + SynTy tc _ _ -> ppBesides [ppPStr SLIT("The type synonym `"), ppr sty tc, rest_of_msg] + TyVarTy tv -> ppBesides [ppPStr SLIT("The type variable `"), ppr sty tv, rest_of_msg] + other -> ppBesides [ppPStr SLIT("The type `"), ppr sty ty, rest_of_msg] where - rest_of_msg = ppStr "' cannot be used as an instance type." + rest_of_msg = ppPStr SLIT("' cannot be used as an instance type.") derivingWhenInstanceExistsErr clas tycon sty - = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"]) - 4 (ppStr "when an explicit instance exists") + = ppHang (ppBesides [ppPStr SLIT("Deriving class `"), + ppr sty clas, + ppPStr SLIT("' type `"), ppr sty tycon, ppChar '\'']) + 4 (ppPStr SLIT("when an explicit instance exists")) derivingWhenInstanceImportedErr inst_mod clas tycon sty - = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"]) - 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"]) + = ppHang (ppBesides [ppPStr SLIT("Deriving class `"), + ppr sty clas, + ppPStr SLIT("' type `"), ppr sty tycon, ppChar '\'']) + 4 (ppBesides [ppPStr SLIT("when an instance declared in module `"), + pp_mod, ppPStr SLIT("' has been imported")]) where - pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"] + pp_mod = ppBesides [ppPStr SLIT("module `"), ppPStr inst_mod, ppChar '\''] nonBoxedPrimCCallErr clas inst_ty sty - = ppHang (ppStr "Unacceptable instance type for ccall-ish class") - 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `", - ppr sty inst_ty, ppStr "'"]) + = ppHang (ppPStr SLIT("Unacceptable instance type for ccall-ish class")) + 4 (ppBesides [ ppPStr SLIT("class `"), ppr sty clas, ppPStr SLIT("' type `"), + ppr sty inst_ty, ppChar '\'']) omitDefaultMethodWarn clas_op clas_name inst_ty sty - = ppCat [ppStr "Warning: Omitted default method for", - ppr sty clas_op, ppStr "in instance", + = ppCat [ppPStr SLIT("Warning: Omitted default method for"), + ppr sty clas_op, ppPStr SLIT("in instance"), ppStr clas_name, pprParendGenType sty inst_ty] instMethodNotInClassErr occ clas sty - = ppHang (ppStr "Instance mentions a method not in the class") - 4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `", - ppr sty occ, ppStr "'"]) + = ppHang (ppPStr SLIT("Instance mentions a method not in the class")) + 4 (ppBesides [ppPStr SLIT("class `"), ppr sty clas, ppPStr SLIT("' method `"), + ppr sty occ, ppChar '\'']) patMonoBindsCtxt pbind sty - = ppHang (ppStr "In a pattern binding:") + = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty pbind) methodSigCtxt name ty sty - = ppHang (ppBesides [ppStr "When matching the definition of class method `", - ppr sty name, ppStr "' to its signature :" ]) + = ppHang (ppBesides [ppPStr SLIT("When matching the definition of class method `"), + ppr sty name, ppPStr SLIT("' to its signature :") ]) 4 (ppr sty ty) bindSigCtxt method_ids sty - = ppHang (ppStr "When checking type signatures for: ") + = ppHang (ppPStr SLIT("When checking type signatures for: ")) 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids)) superClassSigCtxt sty - = ppStr "When checking superclass constraints on instance declaration" + = ppPStr SLIT("When checking superclass constraints on instance declaration") \end{code} diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index f43b4cd530..e4dd21f764 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -20,7 +20,7 @@ import HsSyn ( MonoBinds, Fake, InPat, Sig ) import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..), RenamedInstancePragmas(..) ) -import TcEnv ( tcLookupGlobalValueMaybe ) +import TcEnv ( tcAddImportedIdInfo ) import TcMonad import Inst ( SYN_IE(InstanceMapper) ) @@ -30,7 +30,7 @@ import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv), SYN_IE(ClassOp) ) import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) -import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, replaceIdInfo, getIdInfo ) +import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal ) import MatchEnv ( nullMEnv, insertMEnv ) import Maybes ( MaybeErr(..), mkLookupFunDef ) import Name ( getSrcLoc, Name{--O only-} ) @@ -45,7 +45,6 @@ import Unique ( Unique ) import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-} ) --import PprStyle -import IdInfo ( noIdInfo ) --import TcPragmas ( tcDictFunPragmas, tcGenPragmas ) \end{code} @@ -84,17 +83,8 @@ mkInstanceRelatedIds :: Name -- Name to use for the dict fun; -> NF_TcM s (Id, ThetaType) mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta - = tcLookupGlobalValueMaybe dfun_name `thenNF_Tc` \ maybe_id -> - let - -- Extract the dfun's IdInfo from the interface file, - -- provided it's imported. - -- We have to be lazy here; people look at the dfun Id itself - dfun_info = case maybe_id of - Nothing -> noIdInfo - Just imported_dfun_id -> getIdInfo imported_dfun_id - in - returnNF_Tc (new_dfun_id `replaceIdInfo` dfun_info, dfun_theta) - + = tcAddImportedIdInfo dfun_id `thenNF_Tc` \ new_dfun_id -> + returnNF_Tc (new_dfun_id, dfun_theta) where (_, super_classes, _, _, _, _) = classBigSig clas super_class_theta = super_classes `zip` repeat inst_ty @@ -110,7 +100,7 @@ mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty) - new_dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty + dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty \end{code} @@ -239,10 +229,10 @@ addClassInstance dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2) -- Overlapping/duplicate instances for given class; msg could be more glamourous = tcAddErrCtxt ctxt $ - failTc (\sty -> ppStr "Duplicate or overlapping instance declarations") + failTc (\sty -> ppPStr SLIT("Duplicate or overlapping instance declarations")) where - ctxt sty = ppHang (ppSep [ppBesides[ppStr "Class `", ppr sty clas, ppStr "'"], - ppBesides[ppStr "type `", ppr sty ty1, ppStr "'"]]) - 4 (ppSep [ppBesides [ppStr "at ", ppr sty locn1], - ppBesides [ppStr "and ", ppr sty locn2]]) + ctxt sty = ppHang (ppSep [ppBesides[ppPStr SLIT("Class `"), ppr sty clas, ppChar '\''], + ppBesides[ppPStr SLIT("type `"), ppr sty ty1, ppChar '\'']]) + 4 (ppSep [ppBesides [ppPStr SLIT("at "), ppr sty locn1], + ppBesides [ppPStr SLIT("and "), ppr sty locn2]]) \end{code} diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index f284526f93..8dd9e5bd82 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -179,11 +179,11 @@ instance Outputable (TcKind s) where ppr sty kind = ppr_kind sty kind ppr_kind sty TcTypeKind - = ppStr "*" + = ppChar '*' ppr_kind sty (TcArrowKind kind1 kind2) - = ppSep [ppr_parend sty kind1, ppStr "->", ppr_kind sty kind2] + = ppSep [ppr_parend sty kind1, ppPStr SLIT("->"), ppr_kind sty kind2] ppr_kind sty (TcVarKind uniq box) - = ppBesides [ppStr "k", pprUnique10 uniq] + = ppBesides [ppChar 'k', pprUnique10 uniq] ppr_parend sty kind@(TcArrowKind _ _) = ppBesides [ppChar '(', ppr_kind sty kind, ppChar ')'] ppr_parend sty other_kind = ppr_kind sty other_kind @@ -195,20 +195,20 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} unifyKindCtxt kind1 kind2 sty - = ppHang (ppStr "When unifying two kinds") 4 - (ppSep [ppr sty kind1, ppStr "and", ppr sty kind2]) + = ppHang (ppPStr SLIT("When unifying two kinds")) 4 + (ppSep [ppr sty kind1, ppPStr SLIT("and"), ppr sty kind2]) kindOccurCheck kind1 kind2 sty - = ppHang (ppStr "Cannot construct the infinite kind:") 4 - (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"], - ppStr "=", - ppBesides [ppStr "`", ppr sty kind1, ppStr "'"], - ppStr "(\"occurs check\")"]) + = ppHang (ppPStr SLIT("Cannot construct the infinite kind:")) 4 + (ppSep [ppBesides [ppChar '`', ppr sty kind1, ppChar '\''], + ppChar '=', + ppBesides [ppChar '`', ppr sty kind1, ppChar '\''], + ppPStr SLIT("(\"occurs check\")")]) kindMisMatchErr kind1 kind2 sty - = ppHang (ppStr "Couldn't match the kind") 4 - (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"], - ppStr "against", - ppBesides [ppStr "`", ppr sty kind2, ppStr "'"] + = ppHang (ppPStr SLIT("Couldn't match the kind")) 4 + (ppSep [ppBesides [ppChar '`', ppr sty kind1, ppChar '\''], + ppPStr SLIT("against"), + ppBesides [ppChar '`', ppr sty kind2, ppChar '\''] ]) \end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 8a7d52053e..143f0b4733 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -208,16 +208,16 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} matchCtxt MCase match sty - = ppHang (ppStr "In a \"case\" branch:") + = ppHang (ppPStr SLIT("In a \"case\" branch:")) 4 (pprMatch sty True{-is_case-} match) matchCtxt (MFun fun) match sty - = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':']) + = ppHang (ppBesides [ppPStr SLIT("In an equation for function "), ppr sty fun, ppChar ':']) 4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match]) \end{code} \begin{code} varyingArgsErr name matches sty - = ppSep [ppStr "Varying number of arguments for function", ppr sty name] + = ppSep [ppPStr SLIT("Varying number of arguments for function"), ppr sty name] \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index a5c3197f5a..34e2dbb895 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -303,17 +303,17 @@ tcCheckMainSig mod_name | otherwise = primIoTyCon_NAME mainTyCheckCtxt main_name sty - = ppCat [ppStr "When checking that", ppr sty main_name, ppStr "has the required type"] + = ppCat [ppPStr SLIT("When checking that"), ppr sty main_name, ppPStr SLIT("has the required type")] noMainErr mod_name main_name sty - = ppCat [ppStr "Module", pprModule sty mod_name, - ppStr "must include a definition for", ppr sty main_name] + = ppCat [ppPStr SLIT("Module"), pprModule sty mod_name, + ppPStr SLIT("must include a definition for"), ppr sty main_name] mainTyMisMatch :: Name -> Type -> TcType s -> Error mainTyMisMatch main_name expected actual sty - = ppHang (ppCat [ppr sty main_name, ppStr "has the wrong type"]) + = ppHang (ppCat [ppr sty main_name, ppPStr SLIT("has the wrong type")]) 4 (ppAboves [ - ppCat [ppStr "Expected:", ppr sty expected], - ppCat [ppStr "Inferred:", ppr sty actual] + ppCat [ppPStr SLIT("Expected:"), ppr sty expected], + ppCat [ppPStr SLIT("Inferred:"), ppr sty actual] ]) \end{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 71c7dd1ae2..2cda4e46b4 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -49,6 +49,7 @@ import Type ( SYN_IE(Type), GenType ) import TyVar ( SYN_IE(TyVar), GenTyVar ) import Usage ( SYN_IE(Usage), GenUsage ) import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) ) +import CmdLineOpts ( opt_PprStyle_All ) import SST import Bag ( Bag, emptyBag, isEmptyBag, @@ -484,20 +485,30 @@ mkTcErr :: SrcLoc -- Where -> TcError -- The complete error report mkTcErr locn ctxt msg sty - = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty]) - 4 (ppAboves [msg sty | msg <- ctxt]) + = ppHang (ppBesides [ppr PprForUser locn, ppPStr SLIT(": "), msg sty]) + 4 (ppAboves [msg sty | msg <- ctxt_to_use]) + where + ctxt_to_use = + if opt_PprStyle_All then + ctxt + else + takeAtMost 4 ctxt + takeAtMost :: Int -> [a] -> [a] + takeAtMost 0 ls = [] + takeAtMost n [] = [] + takeAtMost n (x:xs) = x:takeAtMost (n-1) xs arityErr kind name n m sty - = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ", + = ppBesides [ ppChar '`', ppr sty name, ppPStr SLIT("' should have "), n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'] where errmsg = kind ++ " has too " ++ quantity ++ " arguments" quantity | m < n = "few" | otherwise = "many" - n_arguments | n == 0 = ppStr "no arguments" - | n == 1 = ppStr "1 argument" - | True = ppCat [ppInt n, ppStr "arguments"] + n_arguments | n == 0 = ppPStr SLIT("no arguments") + | n == 1 = ppPStr SLIT("1 argument") + | True = ppCat [ppInt n, ppPStr SLIT("arguments")] \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 39ecb691a6..eb7fc82cf8 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -208,5 +208,5 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} naughtyCCallContextErr clas_name sty - = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"] + = ppSep [ppPStr SLIT("Can't use class"), ppr sty clas_name, ppPStr SLIT("in a context")] \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index db3060e750..cb8fdd36ac 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -11,8 +11,8 @@ module TcPat ( tcPat ) where IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qualifier, HsType, Fixity, - ArithSeqInfo, Stmt, Fake ) + Match, HsBinds, HsType, Fixity, + ArithSeqInfo, Stmt, DoOrListComp, Fake ) import RnHsSyn ( SYN_IE(RenamedPat) ) import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) ) @@ -45,7 +45,7 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) -import Unique ( Unique, eqClassOpKey ) +import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) import Util ( assertPanic, panic ) \end{code} @@ -303,6 +303,30 @@ tcPat (LitPatIn lit@(HsFrac f)) tcPat (LitPatIn lit@(HsLitLit s)) = error "tcPat: can't handle ``literal-literal'' patterns" + +tcPat (NPlusKPatIn name lit@(HsInt i)) + = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local -> + let + local_ty = idType local + in + tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> + tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id -> + + newOverloadedLit origin + (OverloadedIntegral i) local_ty `thenNF_Tc` \ (lie1, over_lit_id) -> + + newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) -> + newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) -> + + returnTc (NPlusKPat (TcId local) lit local_ty + (SectionR (HsVar ge_id) (HsVar over_lit_id)) + (SectionR (HsVar minus_id) (HsVar over_lit_id)), + lie1 `plusLIE` lie2 `plusLIE` lie3, + local_ty) + where + origin = LiteralOrigin lit -- Not very good! + +tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" \end{code} %************************************************************************ @@ -353,13 +377,13 @@ matchConArgTys con arg_tys Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat) +patCtxt pat sty = ppHang (ppPStr SLIT("In the pattern:")) 4 (ppr sty pat) recordLabel field_label sty - = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label]) - 4 (ppBesides [ppStr "with its immediately enclosing constructor"]) + = ppHang (ppBesides [ppPStr SLIT("When matching record field"), ppr sty field_label]) + 4 (ppBesides [ppPStr SLIT("with its immediately enclosing constructor")]) recordRhs field_label pat sty - = ppHang (ppStr "In the record field pattern") - 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat]) + = ppHang (ppPStr SLIT("In the record field pattern")) + 4 (ppSep [ppr sty field_label, ppChar '=', ppr sty pat]) \end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index a589499cca..2aa4ef5afa 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -15,8 +15,8 @@ module TcSimplify ( IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, Qualifier, HsType, ArithSeqInfo, Fixity, - GRHSsAndBinds, Stmt, Fake ) + Match, HsBinds, HsType, ArithSeqInfo, Fixity, + GRHSsAndBinds, Stmt, DoOrListComp, Fake ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) ) import TcMonad @@ -401,7 +401,7 @@ trySC :: LIE s -- Givens trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc) | not (maybeToBool maybe_best_subclass_chain) = -- No superclass relationship - returnNF_Tc (givens, emptyBag, unitLIE wanted) + returnNF_Tc ((wanted `consLIE` givens), emptyBag, unitLIE wanted) | otherwise = -- There's a subclass relationship with a "given" @@ -457,11 +457,9 @@ sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of sortSC dicts = sortLt lt (bagToList dicts) where (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _) - = if ty1 `eqSimpleTy` ty2 then - maybeToBool (c2 `isSuperClassOf` c1) - else - -- Order is immaterial, I think... - False + = maybeToBool (c2 `isSuperClassOf` c1) + -- The ice is a bit thin here because this "lt" isn't a total order + -- But it *is* transitive, so it works ok \end{code} @@ -712,7 +710,7 @@ now? \begin{code} genCantGenErr insts sty -- Can't generalise these Insts - = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):") + = ppHang (ppPStr SLIT("Cannot generalise these overloadings (in a _ccall_):")) 4 (ppAboves (map (ppr sty) (bagToList insts))) \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 359e29c67e..284946fa55 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -248,7 +248,7 @@ get_tys tys get_sigs sigs = unionManyUniqSets (map get_sig sigs) where - get_sig (ClassOpSig _ ty _ _) = get_ty ty + get_sig (ClassOpSig _ _ ty _) = get_ty ty get_sig other = panic "TcTyClsDecls:get_sig" set_name name = unitUniqSet (uniqueOf name) @@ -306,9 +306,9 @@ get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _)) sigs_tvs sigs = unionManyBags (map sig_tvs sigs) where - sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty - pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar - pty_tvs other = emptyBag + sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty + pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar + pty_tvs other = emptyBag \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 00f16116e4..a36845c32a 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -16,7 +16,7 @@ IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo, + HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo, HsType, Fake, InPat, HsTyVar, Fixity, Bind(..), MonoBinds(..), Sig ) @@ -350,19 +350,19 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} tySynCtxt tycon_name sty - = ppCat [ppStr "In the type declaration for", ppr sty tycon_name] + = ppCat [ppPStr SLIT("In the type declaration for"), ppr sty tycon_name] tyDataCtxt tycon_name sty - = ppCat [ppStr "In the data declaration for", ppr sty tycon_name] + = ppCat [ppPStr SLIT("In the data declaration for"), ppr sty tycon_name] tyNewCtxt tycon_name sty - = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name] + = ppCat [ppPStr SLIT("In the newtype declaration for"), ppr sty tycon_name] fieldTypeMisMatch field_name sty - = ppSep [ppStr "Declared types differ for field", ppr sty field_name] + = ppSep [ppPStr SLIT("Declared types differ for field"), ppr sty field_name] missingEvalErr con eval_theta sty - = ppCat [ppStr "Missing Eval context for constructor", + = ppCat [ppPStr SLIT("Missing Eval context for constructor"), ppQuote (ppr sty con), - ppStr ":", ppr sty eval_theta] + ppChar ':', ppr sty eval_theta] \end{code} diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 57b4a09d48..30d7995c88 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -333,32 +333,32 @@ unifyCtxt ty1 ty2 -- ty1 expected, ty2 inferred returnNF_Tc (err ty1' ty2') where err ty1' ty2' sty = ppAboves [ - ppCat [ppStr "Expected:", ppr sty ty1'], - ppCat [ppStr "Inferred:", ppr sty ty2'] + ppCat [ppPStr SLIT("Expected:"), ppr sty ty1'], + ppCat [ppPStr SLIT("Inferred:"), ppr sty ty2'] ] unifyMisMatch ty1 ty2 sty - = ppHang (ppStr "Couldn't match the type") - 4 (ppSep [ppr sty ty1, ppStr "against", ppr sty ty2]) + = ppHang (ppPStr SLIT("Couldn't match the type")) + 4 (ppSep [ppr sty ty1, ppPStr SLIT("against"), ppr sty ty2]) expectedFunErr ty sty = ppHang (ppStr "Function type expected, but found the type") 4 (ppr sty ty) unifyKindErr tyvar ty sty - = ppHang (ppStr "Compiler bug: kind mis-match between") - 4 (ppSep [ppCat [ppr sty tyvar, ppStr "::", ppr sty (tyVarKind tyvar)], - ppStr "and", - ppCat [ppr sty ty, ppStr "::", ppr sty (typeKind ty)]]) + = ppHang (ppPStr SLIT("Compiler bug: kind mis-match between")) + 4 (ppSep [ppCat [ppr sty tyvar, ppPStr SLIT("::"), ppr sty (tyVarKind tyvar)], + ppPStr SLIT("and"), + ppCat [ppr sty ty, ppPStr SLIT("::"), ppr sty (typeKind ty)]]) unifyDontBindErr tyvar ty sty - = ppHang (ppStr "Couldn't match the *signature/existential* type variable") + = ppHang (ppPStr SLIT("Couldn't match the signature/existential type variable")) 4 (ppSep [ppr sty tyvar, - ppStr "with the type", + ppPStr SLIT("with the type"), ppr sty ty]) unifyOccurCheck tyvar ty sty - = ppHang (ppStr "Cannot construct the infinite type (occur check)") - 4 (ppSep [ppr sty tyvar, ppStr "=", ppr sty ty]) + = ppHang (ppPStr SLIT("Cannot construct the infinite type (occur check)")) + 4 (ppSep [ppr sty tyvar, ppChar '=', ppr sty ty]) \end{code} diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index cb29e48cce..e058fb349e 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -91,9 +91,9 @@ Printing instance Outputable Kind where ppr sty kind = pprKind kind -pprKind TypeKind = ppStr "**" -- Can be boxed or unboxed -pprKind BoxedTypeKind = ppStr "*" -pprKind UnboxedTypeKind = ppStr "*#" -- Unboxed +pprKind TypeKind = ppChar '*' -- Can be boxed or unboxed +pprKind BoxedTypeKind = ppChar '*' +pprKind UnboxedTypeKind = ppStr "*#" -- Unboxed pprKind (ArrowKind k1 k2) = ppSep [pprParendKind k1, ppStr "->", pprKind k2] pprParendKind k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen] diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index a0adc7dc8f..3d036855c2 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -31,7 +31,7 @@ IMPORT_DELOOPER(IdLoop) -- friends: -- (PprType can see all the representations it's trying to print) import Type ( GenType(..), maybeAppTyCon, - splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy ) + splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys ) import TyVar ( GenTyVar(..) ) import TyCon ( TyCon(..), NewOrData ) import Class ( SYN_IE(Class), GenClass(..), @@ -51,7 +51,7 @@ import PprEnv import PprStyle ( PprStyle(..), codeStyle, showUserishTypes ) import Pretty import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-} ) -import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey ) +import Unique --TEMP: ( pprUnique10, pprUnique, incrUnique, listTyConKey ) import Util \end{code} @@ -177,13 +177,13 @@ ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) -- so that right associativity comes out nicely... = maybeParen ctxt_prec fUN_PREC (ppCat [ppr_ty env fUN_PREC ty1, - ppPStr SLIT("->"), + ppStr "->", ppr_ty env tOP_PREC ty2]) ppr_ty env ctxt_prec ty@(AppTy _ _) = ppr_corner env ctxt_prec fun_ty arg_tys where - (fun_ty, arg_tys) = splitAppTy ty + (fun_ty, arg_tys) = splitAppTys ty ppr_ty env ctxt_prec (SynTy tycon tys expansion) | codeStyle (pStyle env) @@ -275,7 +275,7 @@ pprGenTyVar sty (TyVar uniq kind name usage) = case sty of PprInterface -> pp_u _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"] - where + where pp_u = pprUnique uniq pp_name = case name of Just n -> pprOccName sty (getOccName n) @@ -356,11 +356,11 @@ pprTyCon sty (SpecTyCon tc ty_maybes) pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion) = ppBeside (ppr sty name) (ifPprShowAll sty - (ppCat [ ppStr " {-", + (ppCat [ ppPStr SLIT(" {-"), ppInt arity, interpp'SP sty tyvars, pprParendGenType sty expansion, - ppStr "-}"])) + ppPStr SLIT("-}")])) -} \end{code} @@ -405,7 +405,7 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) getTypeString :: Type -> FAST_STRING getTypeString ty - = case (splitAppTy ty) of { (tc, args) -> + = case (splitAppTys ty) of { (tc, args) -> _CONCAT_ (do_tc tc : map do_arg_ty args) } where do_tc (TyConTy tc _) = nameString (getName tc) @@ -537,7 +537,7 @@ nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly tvenv u) of Just xx -> (nenv, xx) Nothing -> - --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $ + --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppPStr SLIT("=>"), ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $ (nenv, tv) \end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index d473ea48d7..0460e6ef7e 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -34,7 +34,7 @@ module TyCon( getSynTyConDefn, maybeTyConSingleCon, - isEnumerationTyCon, + isEnumerationTyCon, isTupleTyCon, derivedFor ) where @@ -79,6 +79,11 @@ data TyCon [TyVar] [(Class,Type)] -- Its context [Id] -- Its data constructors, with fully polymorphic types + -- This list can be empty, when we import a data type abstractly, + -- either (a) the interface is hand-written and doesn't give + -- the constructors, or + -- (b) in a quest for fast compilation we don't import + -- the constructors [Class] -- Classes which have derived instances NewOrData @@ -275,6 +280,13 @@ isEnumerationTyCon (TupleTyCon _ _ arity) = arity == 0 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) = not (null data_cons) && all isNullaryDataCon data_cons + + +isTupleTyCon (TupleTyCon _ _ arity) = arity >= 2 -- treat "0-tuple" specially +isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc +isTupleTyCon other = False + + \end{code} @derivedFor@ reports if we have an {\em obviously}-derived instance diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index 1086dec90e..267140fd1b 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -3,7 +3,8 @@ Breaks the TyCon/types loop and the types/Id loop. \begin{code} interface TyLoop where -import PreludePS(_PackedString) +--import PreludePS(_PackedString) +import FastString (FastString) import PreludeStdIO ( Maybe ) import Unique ( Unique ) @@ -34,7 +35,7 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -- Needed in TyCon tupleCon :: Int -> Id isNullaryDataCon :: Id -> Bool -specMaybeTysSuffix :: [Maybe Type] -> _PackedString +specMaybeTysSuffix :: [Maybe Type] -> FastString idType :: Id -> Type splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u) splitFunTy :: GenType t u -> ([GenType t u], GenType t u) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 5888c27bca..229b5aedcc 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -5,7 +5,7 @@ module Type ( GenType(..), SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, mkFunTy, mkFunTys, splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking, getFunTy_maybe, getFunTyExpandingDicts_maybe, @@ -37,7 +37,8 @@ module Type ( isTauTy, - tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind + tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + showTypeCategory ) where IMP_Ubiq() @@ -48,7 +49,7 @@ IMPORT_DELOOPER(TyLoop) -- friends: import Class ( classSig, classOpLocalType, GenClass{-instances-} ) import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) -import TyCon ( mkFunTyCon, isFunTyCon, +import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon, isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), @@ -210,8 +211,13 @@ mkAppTy = AppTy mkAppTys :: GenType t u -> [GenType t u] -> GenType t u mkAppTys t ts = foldl AppTy t ts -splitAppTy :: GenType t u -> (GenType t u, [GenType t u]) -splitAppTy t = go t [] +splitAppTy :: GenType t u -> (GenType t u, GenType t u) +splitAppTy (AppTy t arg) = (t,arg) +splitAppTy (SynTy _ _ t) = splitAppTy t +splitAppTy other = panic "splitAppTy" + +splitAppTys :: GenType t u -> (GenType t u, [GenType t u]) +splitAppTys t = go t [] where go (AppTy t arg) ts = go t (arg:ts) go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts) @@ -421,7 +427,7 @@ maybeAppTyCon ty Nothing -> Nothing Just tycon -> Just (tycon, arg_tys) where - (app_ty, arg_tys) = splitAppTy ty + (app_ty, arg_tys) = splitAppTys ty getAppTyCon @@ -456,7 +462,7 @@ maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty maybe_app_data_tycon expand ty = let expanded_ty = expand ty - (app_ty, arg_tys) = splitAppTy expanded_ty + (app_ty, arg_tys) = splitAppTys expanded_ty in case (getTyCon_maybe app_ty) of Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $ @@ -743,7 +749,9 @@ tc_primrep_list ,(stablePtrPrimTyConKey, StablePtrRep) ,(statePrimTyConKey, VoidRep) ,(synchVarPrimTyConKey, PtrRep) - ,(voidTyConKey, VoidRep) + ,(voidTyConKey, PtrRep) -- Not VoidRep! That's just for Void# + -- The type Void is represented by a pointer to + -- a bottom closure. ,(wordPrimTyConKey, WordRep) ] \end{code} @@ -930,3 +938,53 @@ eqTy t1 t2 = eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2 eqBounds uve _ _ = False \end{code} + +\begin{code} +showTypeCategory :: Type -> Char + {- + {C,I,F,D} char, int, float, double + T tuple + S other single-constructor type + {c,i,f,d} unboxed ditto + t *unpacked* tuple + s *unpacked" single-cons... + + v void# + a primitive array + + E enumeration type + + dictionary, unless it's a ... + L List + > function + M other (multi-constructor) data-con type + . other type + - reserved for others to mark as "uninteresting" + -} +showTypeCategory ty + = if isDictTy ty + then '+' + else + case getTyCon_maybe ty of + Nothing -> if maybeToBool (getFunTy_maybe ty) + then '>' + else '.' + + Just tycon -> + let utc = uniqueOf tycon in + if utc == charDataConKey then 'C' + else if utc == intDataConKey then 'I' + else if utc == floatDataConKey then 'F' + else if utc == doubleDataConKey then 'D' + else if utc == integerDataConKey then 'J' + else if utc == charPrimTyConKey then 'c' + else if (utc == intPrimTyConKey || utc == wordPrimTyConKey + || utc == addrPrimTyConKey) then 'i' + else if utc == floatPrimTyConKey then 'f' + else if utc == doublePrimTyConKey then 'd' + else if isPrimTyCon tycon {- array, we hope -} then 'A' + else if isEnumerationTyCon tycon then 'E' + else if isTupleTyCon tycon then 'T' + else if maybeToBool (maybeTyConSingleCon tycon) then 'S' + else if utc == listTyConKey then 'L' + else 'M' -- oh, well... +\end{code} diff --git a/ghc/compiler/utils/Argv.lhs b/ghc/compiler/utils/Argv.lhs index 821a806e88..c9ba42baf0 100644 --- a/ghc/compiler/utils/Argv.lhs +++ b/ghc/compiler/utils/Argv.lhs @@ -17,7 +17,11 @@ CHK_Ubiq() -- debugging consistency check # define PACK_STR packCString #else # define ADDR _Addr +# define PACK_STR mkFastCharString +/* +# define ADDR _Addr # define PACK_STR _packCString +*/ #endif argv :: [FAST_STRING] diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index 15678cfbe8..a22ccde400 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -16,7 +16,7 @@ module Bag ( #ifndef COMPILING_GHC elemBag, #endif - filterBag, partitionBag, concatBag, foldBag, + filterBag, partitionBag, concatBag, foldBag, foldrBag, isEmptyBag, consBag, snocBag, listToBag, bagToList ) where @@ -130,6 +130,16 @@ foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 foldBag t u e (ListBag xs) = foldr (t.u) e xs foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs +foldrBag :: (a -> r -> r) -> r + -> Bag a + -> r + +foldrBag k z EmptyBag = z +foldrBag k z (UnitBag x) = k x z +foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 +foldrBag k z (ListBag xs) = foldr k z xs +foldrBag k z (ListOfBags bs) = foldr (\b r -> foldrBag k r b) z bs + mapBag :: (a -> b) -> Bag a -> Bag b mapBag f EmptyBag = EmptyBag @@ -144,24 +154,14 @@ listToBag [] = EmptyBag listToBag vs = ListBag vs bagToList :: Bag a -> [a] -bagToList EmptyBag = [] -bagToList (ListBag vs) = vs -bagToList b = bagToList_append b [] - - -- (bagToList_append b xs) flattens b and puts xs on the end. - -- (not exported) -bagToList_append EmptyBag xs = xs -bagToList_append (UnitBag x) xs = x:xs -bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs) -bagToList_append (ListBag xx) xs = xx++xs -bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs +bagToList b = foldrBag (:) [] b \end{code} \begin{code} #ifdef COMPILING_GHC instance (Outputable a) => Outputable (Bag a) where - ppr sty EmptyBag = ppStr "emptyBag" + ppr sty EmptyBag = ppPStr SLIT("emptyBag") ppr sty (UnitBag a) = ppr sty a ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2] ppr sty (ListBag as) = interpp'SP sty as diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs index 43dfb7f478..d5e7c33de3 100644 --- a/ghc/compiler/utils/CharSeq.lhs +++ b/ghc/compiler/utils/CharSeq.lhs @@ -196,7 +196,8 @@ cPutStr handle sq = flat sq flat (CCh c) = hPutChar handle c flat (CInt i) = hPutStr handle (show i) flat (CStr s) = hPutStr handle s - flat (CPStr s) = hPutStr handle (_UNPK_ s) + flat (CPStr s) = hPutFS handle s + --hPutStr handle (_UNPK_ s) #endif {- COMPILING_GHC -} \end{code} diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs new file mode 100644 index 0000000000..ab54af7784 --- /dev/null +++ b/ghc/compiler/utils/FastString.lhs @@ -0,0 +1,505 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% +\section{Fast strings} + +Compact representations of character strings with +unique identifiers. + +\begin{code} +module FastString + ( + FastString(..), -- not abstract, for now. + + --names? + mkFastString, -- :: String -> FastString + mkFastCharString, -- :: _Addr -> FastString + mkFastCharString2, -- :: _Addr -> Int -> FastString + mkFastSubString, -- :: _Addr -> Int -> Int -> FastString + mkFastSubStringFO, -- :: ForeignObj -> Int -> Int -> FastString + + mkFastString#, -- :: Addr# -> Int# -> FastString + mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString + mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString + mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString + + lengthFS, -- :: FastString -> Int + nullFastString, -- :: FastString -> Bool + + getByteArray#, -- :: FastString -> ByteArray# + getByteArray, -- :: FastString -> _ByteArray Int + unpackFS, -- :: FastString -> String + appendFS, -- :: FastString -> FastString -> FastString + headFS, -- :: FastString -> Char + tailFS, -- :: FastString -> FastString + concatFS, -- :: [FastString] -> FastString + consFS, -- :: Char -> FastString -> FastString + + hPutFS, -- :: Handle -> FastString -> IO () + tagCmpFS -- :: FastString -> FastString -> _CMP_TAG + ) where + +import PreludeGlaST +import PreludeGlaMisc +import HandleHack + +import PrimPacked +import Ubiq + +#define hASH_TBL_SIZE 993 + +\end{code} + +@FastString@s are packed representations of strings +with a unique id for fast comparisons. The unique id +is assigned when creating the @FastString@, using +a hash table to map from the character string representation +to the unique ID. + +\begin{code} +data FastString + = FastString -- packed repr. on the heap. + Int# -- unique id + -- 0 => string literal, comparison + -- will + Int# -- length + ByteArray# -- stuff + + | CharStr -- external C string + Addr# -- pointer to the (null-terminated) bytes in C land. + Int# -- length (cached) + +instance Eq FastString where + a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True; _GT -> False } + a /= b = case tagCmpFS a b of { _LT -> True; _EQ -> False; _GT -> True } + +{- + (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2# +-} + +instance Uniquable FastString where + uniqueOf (FastString u# _ _) = mkUniqueGrimily u# + uniqueOf (CharStr a# l#) = + {- + [A somewhat moby hack]: to avoid entering all sorts + of junk into the hash table, all C char strings + are by default left out. The benefit of being in + the table is that string comparisons are lightning fast, + just an Int# comparison. + + But, if you want to get the Unique of a CharStr, we + enter it into the table and return that unique. This + works, but causes the CharStr to be looked up in the hash + table each time it is accessed.. + -} + mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh! + +instance Uniquable Int where + uniqueOf (I# i#) = mkUniqueGrimily i# + +instance Text FastString where + readsPrec p = error "readsPrec: FastString: ToDo" + showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r + showsPrec p ps r = showsPrec p (unpackFS ps) r + +getByteArray# :: FastString -> ByteArray# +getByteArray# (FastString _ _ ba#) = ba# + +getByteArray :: FastString -> _ByteArray Int +getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba# + +lengthFS :: FastString -> Int +lengthFS (FastString _ l# _) = I# l# +lengthFS (CharStr a# l#) = I# l# + +nullFastString :: FastString -> Bool +nullFastString (FastString _ l# _) = l# ==# 0# +nullFastString (CharStr _ l#) = l# ==# 0# + +unpackFS :: FastString -> String +unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#) +unpackFS (CharStr addr len#) = + unpack 0# + where + unpack nh + | nh ==# len# = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2) + +concatFS :: [FastString] -> FastString +concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better + +headFS :: FastString -> Char +headFS (FastString _ l# ba#) = + if l# ># 0# then C# (indexCharArray# ba# 0#) else error "headFS: empty FS" +headFS (CharStr a# l#) = + if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error "headFS: empty FS" + +tailFS :: FastString -> FastString +tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#) + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastString (c:unpackFS fs) + +\end{code} + +Internally, the compiler will maintain a fast string symbol +table, providing sharing and fast comparison. Creation of +new @FastString@s then covertly does a lookup, re-using the +@FastString@ if there was a hit. + +\begin{code} +data FastStringTable = + FastStringTable + Int# + (MutableArray# _RealWorld [FastString]) + +type FastStringTableVar = MutableVar _RealWorld FastStringTable + +string_table :: FastStringTableVar +string_table = + unsafePerformPrimIO ( + newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) -> + newVar (FastStringTable 0# arr#)) + +lookupTbl :: FastStringTable -> Int# -> [FastString] +lookupTbl (FastStringTable _ arr#) i# = + unsafePerformPrimIO ( \ (S# s#) -> + case readArray# arr# i# s# of { StateAndPtr# s2# r -> + (r, S# s2#) } ) + +updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO () +updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls (S# s#) = + case writeArray# arr# i# ls s# of { s2# -> + case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# -> + ((), S# s3#) }} + +mkFastString# :: Addr# -> Int# -> FastString +mkFastString# a# len# = + unsafePerformPrimIO ( + readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) -> + let + h = hashStr a# len# + in +-- _trace ("hashed: "++show (I# h)) $ + case lookupTbl ft h of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray +-- _trace "empty bucket" $ + case copyPrefixStr (A# a#) (I# len#) of + (_ByteArray _ barr#) -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h [f_str] `seqPrimIO` + ({- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str) + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. +-- _trace ("non-empty bucket"++show ls) $ + case bucket_match ls len# a# of + Nothing -> + case copyPrefixStr (A# a#) (I# len#) of + (_ByteArray _ barr#) -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h (f_str:ls) `seqPrimIO` + ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str) + Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v) + where + bucket_match [] _ _ = Nothing + bucket_match (v@(FastString _ l# ba#):ls) len# a# = + if len# ==# l# && eqStrPrefix a# ba# l# then + Just v + else + bucket_match ls len# a# + +mkFastSubString# :: Addr# -> Int# -> Int# -> FastString +mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#) + +mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString +mkFastSubStringFO# fo# start# len# = + unsafePerformPrimIO ( + readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) -> + let + h = hashSubStrFO fo# start# len# + in + case lookupTbl ft h of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray + case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of + (_ByteArray _ barr#) -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h [f_str] `seqPrimIO` + returnPrimIO f_str + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + case bucket_match ls start# len# fo# of + Nothing -> + case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of + (_ByteArray _ barr#) -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h (f_str:ls) `seqPrimIO` + ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str) + Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v) + where + bucket_match [] _ _ _ = Nothing + bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# = + if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then + Just v + else + bucket_match ls start# len# fo# + + +mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString +mkFastSubStringBA# barr# start# len# = + unsafePerformPrimIO ( + readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) -> + let + h = hashSubStrBA barr# start# len# + in +-- _trace ("hashed(b): "++show (I# h)) $ + case lookupTbl ft h of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray +-- _trace "empty bucket(b)" $ + case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of + (_ByteArray _ ba#) -> + let f_str = FastString uid# len# ba# in + updTbl string_table ft h [f_str] `seqPrimIO` + ({- _trace ("new(b): " ++ show f_str) $ -} returnPrimIO f_str) + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. +-- _trace ("non-empty bucket(b)"++show ls) $ + case bucket_match ls start# len# barr# of + Nothing -> + case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of + (_ByteArray _ ba#) -> + let f_str = FastString uid# len# ba# in + updTbl string_table ft h (f_str:ls) `seqPrimIO` + ({- _trace ("new(b): " ++ show f_str) $ -} returnPrimIO f_str) + Just v -> {- _trace ("re-use(b): "++show v) $ -} returnPrimIO v) + where + bucket_match [] _ _ _ = Nothing + bucket_match (v:ls) start# len# ba# = + case v of + FastString _ l# barr# -> + if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then + Just v + else + bucket_match ls len# start# ba# + +mkFastCharString :: _Addr -> FastString +mkFastCharString a@(A# a#) = + case strLength a of{ (I# len#) -> CharStr a# len# } + +mkFastCharString2 :: _Addr -> Int -> FastString +mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len# + +mkFastString :: String -> FastString +mkFastString str = + (case stringToByteArray str of + (_ByteArray (_,I# len#) frozen#) -> + -- + -- 0-indexed array, len# == index to one beyond end of string, + -- i.e., (0,1) => empty string. + -- + {- _trace (show (str,I# len#)) $ -} mkFastSubStringBA# frozen# 0# len#) + +mkFastSubString :: _Addr -> Int -> Int -> FastString +mkFastSubString (A# a#) (I# start#) (I# len#) + = mkFastString# (addrOffset# a# start#) len# + +mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString +mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) = + mkFastSubStringFO# fo# start# len# + +\end{code} + +\begin{code} +hashStr :: Addr# -> Int# -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashStr a# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# +{- + if len# ==# 0# then + 0# + else + ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) + `remInt#` hASH_TBL_SIZE# +-} + where + c0 = indexCharOffAddr# a# 0# + c1 = indexCharOffAddr# a# 1# --(len# `quotInt#` 2# -# 1#) + c2 = indexCharOffAddr# a# 2# --(len# -# 1#) + +hashSubStrFO :: ForeignObj# -> Int# -> Int# -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashSubStrFO fo# start# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# +{- + if len# ==# 0# then + 0# + else + ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) + `remInt#` hASH_TBL_SIZE# +-} + where + c0 = indexCharOffFO# fo# 0# + c1 = indexCharOffFO# fo# 1# --(len# `quotInt#` 2# -# 1#) + c2 = indexCharOffFO# fo# 2# --(len# -# 1#) + + +hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashSubStrBA ba# start# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# +{- + if len# ==# 0# then + 0# + else + ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) + `remInt#` hASH_TBL_SIZE# +-} + where + c0 = indexCharArray# ba# 0# + c1 = indexCharArray# ba# 1# --(len# `quotInt#` 2# -# 1#) + c2 = indexCharArray# ba# 2# --(len# -# 1#) + +\end{code} + +\begin{code} +tagCmpFS :: FastString -> FastString -> _CMP_TAG +tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars + if u1# ==# u2# then + _EQ + else + unsafePerformPrimIO ( + _ccall_ strcmp (_ByteArray bottom b1#) (_ByteArray bottom b2#) `thenPrimIO` \ (I# res) -> + returnPrimIO ( + if res <# 0# then _LT + else if res ==# 0# then _EQ + else _GT + )) + where + bottom = error "tagCmp" +tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2) + = unsafePerformPrimIO ( + _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) -> + returnPrimIO ( + if res <# 0# then _LT + else if res ==# 0# then _EQ + else _GT + )) + where + ba1 = A# bs1 + ba2 = A# bs2 +tagCmpFS (FastString _ len1 bs1) (CharStr bs2 len2) + = unsafePerformPrimIO ( + _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) -> + returnPrimIO ( + if res <# 0# then _LT + else if res ==# 0# then _EQ + else _GT + )) + where + ba1 = _ByteArray (error "") bs1 + ba2 = A# bs2 + +tagCmpFS a@(CharStr _ _) b@(FastString _ _ _) + = -- try them the other way 'round + case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT } + +instance Ord FastString where + a <= b = case tagCmpFS a b of { _LT -> True; _EQ -> True; _GT -> False } + a < b = case tagCmpFS a b of { _LT -> True; _EQ -> False; _GT -> False } + a >= b = case tagCmpFS a b of { _LT -> False; _EQ -> True; _GT -> True } + a > b = case tagCmpFS a b of { _LT -> False; _EQ -> False; _GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + _tagCmp a b = tagCmpFS a b + +\end{code} + +Outputting @FastString@s is quick, just block copying the chunk (using +@fwrite@). + +\begin{code} +hPutFS :: Handle -> FastString -> IO () +hPutFS handle (FastString _ l# ba#) = + if l# ==# 0# then + return () + else + _readHandle handle >>= \ htype -> + case htype of + _ErrorHandle ioError -> + _writeHandle handle htype >> + failWith ioError + _ClosedHandle -> + _writeHandle handle htype >> + failWith (IllegalOperation "handle is closed") + _SemiClosedHandle _ _ -> + _writeHandle handle htype >> + failWith (IllegalOperation "handle is closed") + _ReadHandle _ _ _ -> + _writeHandle handle htype >> + failWith (IllegalOperation "handle is not open for writing") + other -> + let fp = _filePtr htype in + -- here we go.. + _ccall_ writeFile (_ByteArray (error "") ba#) fp (I# l#) `thenPrimIO` \rc -> + if rc==0 then + return () + else + _constructError "hPutFS" `thenPrimIO` \ err -> + failWith err +hPutFS handle (CharStr a# l#) = + if l# ==# 0# then + return () + else + _readHandle handle >>= \ htype -> + case htype of + _ErrorHandle ioError -> + _writeHandle handle htype >> + failWith ioError + _ClosedHandle -> + _writeHandle handle htype >> + failWith (IllegalOperation "handle is closed") + _SemiClosedHandle _ _ -> + _writeHandle handle htype >> + failWith (IllegalOperation "handle is closed") + _ReadHandle _ _ _ -> + _writeHandle handle htype >> + failWith (IllegalOperation "handle is not open for writing") + other -> + let fp = _filePtr htype in + -- here we go.. + _ccall_ writeFile (A# a#) fp (I# l#) `thenPrimIO` \rc -> + if rc==0 then + return () + else + _constructError "hPutFS" `thenPrimIO` \ err -> + failWith err + +--ToDo: avoid silly code duplic. +\end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 2f5324e556..d00d6fed04 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -70,8 +70,11 @@ module FiniteMap ( ) where IMPORT_DELOOPER(SpecLoop) +#if defined(USE_FAST_STRINGS) +import FastString +#endif import Maybes -import Bag ( Bag, foldBag ) +import Bag ( Bag, foldrBag ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle ) import Pretty ( SYN_IE(Pretty), PrettyRep ) @@ -215,7 +218,7 @@ unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM listToFM = addListToFM emptyFM #ifdef COMPILING_GHC -bagToFM = foldBag plusFM (\ (k,v) -> unitFM k v) emptyFM +bagToFM = foldrBag (\(k,v) fm -> addToFM fm k v) emptyFM #endif \end{code} diff --git a/ghc/compiler/utils/HandleHack.lhi b/ghc/compiler/utils/HandleHack.lhi new file mode 100644 index 0000000000..d0fad80e42 --- /dev/null +++ b/ghc/compiler/utils/HandleHack.lhi @@ -0,0 +1,26 @@ + +The implementation of FastString output need to get at the representation +to Handles to do a Good Job. Prelude modules in 0.29 does not export +the Handle repr., this little hack fixes this :-) + +Also added mkUniqueGrimily to avoid bootstrap trouble + +\begin{code} +interface HandleHack where + +import PreludeStdIO (Handle(..), _Handle(..), _filePtr,_readHandle, _writeHandle, BufferMode, Maybe) +import PreludeIOError (_constructError,IOError13(..)) +import PreludeGlaST (_MutableArray, _RealWorld) +import Unique ( Unique, mkUniqueGrimily ) + +type Handle = _MutableArray _RealWorld Int _Handle +data _Handle = _ErrorHandle IOError13 | _ClosedHandle | _SemiClosedHandle _Addr (_Addr, Int) | _ReadHandle _Addr (Maybe BufferMode) Bool | _WriteHandle _Addr (Maybe BufferMode) Bool | _AppendHandle _Addr (Maybe BufferMode) Bool | _ReadWriteHandle _Addr (Maybe BufferMode) Bool +data Unique + +mkUniqueGrimily :: Int# -> Unique + +_filePtr :: _Handle -> _Addr +_readHandle :: Handle -> IO _Handle +_writeHandle :: Handle -> _Handle -> IO () +_constructError :: String -> PrimIO IOError13 +\end{code} diff --git a/ghc/compiler/utils/MatchEnv.lhs b/ghc/compiler/utils/MatchEnv.lhs index 81271a2982..6c09616e29 100644 --- a/ghc/compiler/utils/MatchEnv.lhs +++ b/ghc/compiler/utils/MatchEnv.lhs @@ -95,22 +95,22 @@ insertMEnv match_fn (ME alist) key value -- that point. insert [] = returnMaB (ME [(key, value)]) - insert ((t,v) : rest) + insert ls@(r@(t,v) : rest) = case (match_fn t key) of Nothing -> -- New key is not an instance of this existing one, so -- continue down the list. insert rest `thenMaB` \ (ME rest') -> - returnMaB (ME((t,v):rest')) + returnMaB (ME(r:rest')) Just match_info -> -- New key *is* an instance of the old one, so check the -- other way round in case of identity. case (match_fn key t) of - Just _ -> failMaB (t,v) + Just _ -> failMaB r -- Oops; overlap - Nothing -> returnMaB (ME ((key,value):(t,v):rest)) + Nothing -> returnMaB (ME ((key,value):ls)) -- All ok; insert here \end{code} diff --git a/ghc/compiler/utils/PprStyle.lhs b/ghc/compiler/utils/PprStyle.lhs index dfb4ec27ad..3471485aab 100644 --- a/ghc/compiler/utils/PprStyle.lhs +++ b/ghc/compiler/utils/PprStyle.lhs @@ -13,6 +13,7 @@ module PprStyle ( ) where CHK_Ubiq() -- debugging consistency check +IMP_FASTSTRING() -- cheat to force fast string dependency. data PprStyle = PprForUser -- Pretty-print in a way that will diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 8bfd952b36..d610c36044 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -326,12 +326,12 @@ ppSep ps width is_vert \begin{code} speakNth :: Int -> Pretty -speakNth 1 = ppStr "first" -speakNth 2 = ppStr "second" -speakNth 3 = ppStr "third" -speakNth 4 = ppStr "fourth" -speakNth 5 = ppStr "fifth" -speakNth 6 = ppStr "sixth" +speakNth 1 = ppPStr SLIT("first") +speakNth 2 = ppPStr SLIT("second") +speakNth 3 = ppPStr SLIT("third") +speakNth 4 = ppPStr SLIT("fourth") +speakNth 5 = ppPStr SLIT("fifth") +speakNth 6 = ppPStr SLIT("sixth") speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ] where st_nd_rd_th | n_rem_10 == 1 = "st" diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs new file mode 100644 index 0000000000..b2b52e61be --- /dev/null +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -0,0 +1,279 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% +\section{Primitive operations for packed strings} + +Core operations for working on a chunk of bytes. +These operations is the core set needed by the +GHC internally, the code generator and the prelude +libraries. + +\begin{code} +module PrimPacked + ( + strLength, -- :: _Addr -> Int + copyPrefixStr, -- :: _Addr -> Int -> _ByteArray Int + copySubStr, -- :: _Addr -> Int -> Int -> _ByteArray Int + copySubStrFO, -- :: ForeignObj -> Int -> Int -> _ByteArray Int + copySubStrBA, -- :: _ByteArray Int -> Int -> Int -> _ByteArray Int + --packString2, -- :: Addr -> Int -> _ByteArray Int + stringToByteArray, -- :: String -> _ByteArray Int + byteArrayToString, -- :: _ByteArray Int -> String + + eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool + eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool + eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool + eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool + eqStrPrefixFO, -- :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool + + addrOffset#, -- :: Addr# -> Int# -> Addr# + indexCharOffFO# -- :: ForeignObj# -> Int# -> Char# + ) where + +import PreludeGlaST +import PreludeGlaMisc + +\end{code} + +Return the length of a @\\NUL@ terminated character string: + +\begin{code} +strLength :: _Addr -> Int +strLength a = + unsafePerformPrimIO ( + _ccall_ strlen a `thenPrimIO` \ len@(I# _) -> + returnPrimIO len + ) + +\end{code} + +Copying a char string prefix into a byte array, +{\em assuming} the prefix does not contain any +NULs. + +\begin{code} +copyPrefixStr :: _Addr -> Int -> _ByteArray Int +copyPrefixStr (A# a) len@(I# length#) = + unsafePerformPrimIO ( + {- allocate an array that will hold the string + (not forgetting the NUL at the end) + -} + (new_ps_array (length# +# 1#)) `thenPrimIO` \ ch_array -> + _ccall_ memcpy ch_array (A# a) len `thenPrimIO` \ () -> + write_ps_array ch_array length# (chr# 0#) `seqPrimIO` + -- fill in packed string from "addr" + --fill_in ch_array 0# `seqPrimIO` + -- freeze the puppy: + freeze_ps_array ch_array) + where + fill_in :: _MutableByteArray s Int -> Int# -> _ST s () + + fill_in arr_in# idx + | idx ==# length# + = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST` + returnStrictlyST () + | otherwise + = case (indexCharOffAddr# a idx) of { ch -> + write_ps_array arr_in# idx ch `seqStrictlyST` + fill_in arr_in# (idx +# 1#) } + +\end{code} + +Copying out a substring, assume a 0-indexed string: +(and positive lengths, thank you). + +\begin{code} +copySubStr :: _Addr -> Int -> Int -> _ByteArray Int +copySubStr a start length = + unsafePerformPrimIO ( + _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start `thenPrimIO` \ a_start -> + returnPrimIO (copyPrefixStr a_start length)) +\end{code} + +Copying a sub-string out of a ForeignObj + +\begin{code} +copySubStrFO :: _ForeignObj -> Int -> Int -> _ByteArray Int +copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) = + unsafePerformPrimIO ( + {- allocate an array that will hold the string + (not forgetting the NUL at the end) + -} + new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array -> + -- fill in packed string from "addr" + fill_in ch_array 0# `seqStrictlyST` + -- freeze the puppy: + freeze_ps_array ch_array) + where + fill_in :: _MutableByteArray s Int -> Int# -> _ST s () + + fill_in arr_in# idx + | idx ==# length# + = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST` + returnStrictlyST () + | otherwise + = case (indexCharOffFO# fo (idx +# start#)) of { ch -> + write_ps_array arr_in# idx ch `seqStrictlyST` + fill_in arr_in# (idx +# 1#) } + +{- ToDo: add FO primitives.. -} +indexCharOffFO# :: ForeignObj# -> Int# -> Char# +indexCharOffFO# fo# i# = + case unsafePerformPrimIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (_ForeignObj fo#) (I# i#)) of + C# c -> c + +addrOffset# :: Addr# -> Int# -> Addr# +addrOffset# a# i# = + case unsafePerformPrimIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of + A# a -> a + +copySubStrBA :: _ByteArray Int -> Int -> Int -> _ByteArray Int +copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) = + unsafePerformPrimIO ( + {- allocate an array that will hold the string + (not forgetting the NUL at the end) + -} + new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array -> + -- fill in packed string from "addr" + fill_in ch_array 0# `seqStrictlyST` + -- freeze the puppy: + freeze_ps_array ch_array) + where + fill_in :: _MutableByteArray s Int -> Int# -> _ST s () + + fill_in arr_in# idx + | idx ==# length# + = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST` + returnStrictlyST () + | otherwise + = case (indexCharArray# barr# (start# +# idx)) of { ch -> + write_ps_array arr_in# idx ch `seqStrictlyST` + fill_in arr_in# (idx +# 1#) } + +\end{code} + +(Very :-) ``Specialised'' versions of some CharArray things... + +\begin{code} +new_ps_array :: Int# -> _ST s (_MutableByteArray s Int) +write_ps_array :: _MutableByteArray s Int -> Int# -> Char# -> _ST s () +freeze_ps_array :: _MutableByteArray s Int -> _ST s (_ByteArray Int) + +new_ps_array size (S# s) = + case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# -> + (_MutableByteArray (0,I# (size -# 1#)) barr#, S# s2#)} + +write_ps_array (_MutableByteArray _ barr#) n ch (S# s#) = + case writeCharArray# barr# n ch s# of { s2# -> + ((), S# s2#)} + +-- same as unsafeFreezeByteArray +freeze_ps_array (_MutableByteArray ixs arr#) (S# s#) = + case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> + (_ByteArray ixs frozen#, S# s2#) } +\end{code} + +Compare two equal-length strings for equality: + +\begin{code} +eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool +eqStrPrefix a# barr# len# = + unsafePerformPrimIO ( + _ccall_ strncmp (A# a#) (_ByteArray bottom barr#) (I# len#) `thenPrimIO` \ (I# x#) -> + returnPrimIO (x# ==# 0#)) + where + bottom = error "eqStrPrefix" + +eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool +eqCharStrPrefix a1# a2# len# = + unsafePerformPrimIO ( + _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) `thenPrimIO` \ (I# x#) -> + returnPrimIO (x# ==# 0#)) + where + bottom = error "eqStrPrefix" + +eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool +eqStrPrefixBA b1# b2# start# len# = + unsafePerformPrimIO ( + _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' + (_ByteArray bottom b2#) + (I# start#) + (_ByteArray bottom b1#) + (I# len#) `thenPrimIO` \ (I# x#) -> + returnPrimIO (x# ==# 0#)) + where + bottom = error "eqStrPrefixBA" + +eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool +eqCharStrPrefixBA a# b2# start# len# = + unsafePerformPrimIO ( + _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' + (_ByteArray bottom b2#) + (I# start#) + (A# a#) + (I# len#) `thenPrimIO` \ (I# x#) -> + returnPrimIO (x# ==# 0#)) + where + bottom = error "eqCharStrPrefixBA" + +eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool +eqStrPrefixFO fo# barr# start# len# = + unsafePerformPrimIO ( + _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' + (_ForeignObj fo#) + (I# start#) + (_ByteArray bottom barr#) + (I# len#) `thenPrimIO` \ (I# x#) -> + returnPrimIO (x# ==# 0#)) + where + bottom = error "eqStrPrefixFO" +\end{code} + +\begin{code} +byteArrayToString :: _ByteArray Int -> String +byteArrayToString (_ByteArray (I# start#,I# end#) barr#) = + unpack start# + where + unpack nh# + | nh# >=# end# = [] + | otherwise = C# ch : unpack (nh# +# 1#) + where + ch = indexCharArray# barr# nh# + +\end{code} + + +\begin{code} +stringToByteArray :: String -> (_ByteArray Int) +stringToByteArray str = _runST (packStringST str) + +packStringST :: [Char] -> _ST s (_ByteArray Int) +packStringST str = + let len = length str in + packNCharsST len str + +packNCharsST :: Int -> [Char] -> _ST s (_ByteArray Int) +packNCharsST len@(I# length#) str = + {- + allocate an array that will hold the string + (not forgetting the NUL byte at the end) + -} + new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array -> + -- fill in packed string from "str" + fill_in ch_array 0# str `seqStrictlyST` + -- freeze the puppy: + freeze_ps_array ch_array `thenStrictlyST` \ (_ByteArray _ frozen#) -> + returnStrictlyST (_ByteArray (0,len) frozen#) + where + fill_in :: _MutableByteArray s Int -> Int# -> [Char] -> _ST s () + fill_in arr_in# idx [] = + write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST` + returnStrictlyST () + + fill_in arr_in# idx (C# c : cs) = + write_ps_array arr_in# idx c `seqStrictlyST` + fill_in arr_in# (idx +# 1#) cs + +\end{code} + + diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs new file mode 100644 index 0000000000..0af3dfc5de --- /dev/null +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% +\section{String buffers} + +Buffers for scanning string input stored in external arrays. + +\begin{code} +module StringBuffer + ( + StringBuffer, + + -- creation + hGetStringBuffer, -- :: FilePath -> IO StringBuffer + freeStringBuffer, -- :: StringBuffer -> IO () + + -- Lookup + currentChar, -- :: StringBuffer -> Char + currentChar#, -- :: StringBuffer -> Char# + indexSBuffer, -- :: StringBuffer -> Int -> Char + indexSBuffer#, -- :: StringBuffer -> Int# -> Char# + -- relative lookup, i.e, currentChar = lookAhead 0 + lookAhead, -- :: StringBuffer -> Int -> Char + lookAhead#, -- :: StringBuffer -> Int# -> Char# + + -- moving the end point of the current lexeme. + setCurrentPos#, -- :: StringBuffer -> Int# -> StringBuffer + incLexeme, -- :: StringBuffer -> StringBuffer + decLexeme, -- :: StringBuffer -> StringBuffer + + -- move the start and end lexeme pointer on by x units. + stepOn, -- :: StringBuffer -> StringBuffer + stepOnBy#, -- :: StringBuffer -> Int# -> StringBuffer + stepOnTo#, -- :: StringBuffer -> Int# -> StringBuffer + stepOnUntil, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer + stepOverLexeme, -- :: StringBuffer -> StringBuffer + scanNumLit, -- :: Int -> StringBuffer -> (Int, StringBuffer) + expandWhile, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer + expandUntilMatch, -- :: StrinBuffer -> String -> StringBuffer + -- at or beyond end of buffer? + bufferExhausted, -- :: StringBuffer -> Bool + emptyLexeme, -- :: StringBuffer -> Bool + + -- matching + prefixMatch, -- :: StringBuffer -> String -> Bool + untilEndOfString#, -- :: StringBuffer -> Int# + untilEndOfChar#, -- :: StringBuffer -> Int# + untilChar#, -- :: StringBuffer -> Char# -> Int# + + -- conversion + lexemeToString, -- :: StringBuffer -> String + lexemeToByteArray, -- :: StringBuffer -> _ByteArray Int + lexemeToFastString, -- :: StringBuffer -> FastString + lexemeToBuffer, -- :: StringBuffer -> StringBuffer + + FastString, + _ByteArray + ) where + +import Ubiq +import PreludeGlaST +import PreludeGlaMisc +import PrimPacked +import FastString +import HandleHack + +\end{code} + +\begin{code} +data StringBuffer + = StringBuffer + Addr# +-- ForeignObj# -- the data + Int# -- length + Int# -- lexeme start + Int# -- current pos +\end{code} + +\begin{code} + +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = +-- _trace ("Renamer: opening " ++ fname) + openFile fname ReadMode >>= \ hndl -> + hFileSize hndl >>= \ len@(J# _ _ d#) -> + let len_i = fromInteger len in + -- Allocate an array for system call to store its bytes into. + -- ToDo: make it robust +-- _trace (show (len_i::Int)+1) + (_casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int)) `thenPrimIO` \ arr@(A# a#) -> + if addr2Int# a# ==# 0# then + failWith (UserError ("hGetStringBuffer: Could not allocate "++show len_i ++ " bytes")) + else + +-- _casm_ `` %r=NULL; '' `thenPrimIO` \ free_p -> +-- makeForeignObj arr free_p `thenPrimIO` \ fo@(_ForeignObj fo#) -> + _readHandle hndl >>= \ _hndl -> + _writeHandle hndl _hndl >> + let ptr = _filePtr _hndl in + _ccall_ fread arr (1::Int) len_i ptr `thenPrimIO` \ (I# read#) -> +-- _trace ("DEBUG: opened " ++ fname ++ show (I# read#)) $ + hClose hndl >> + if read# ==# 0# then -- EOF or other error + failWith (UserError "hGetStringBuffer: EOF reached or some other error") + else + -- Add a sentinel NUL + _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' arr (I# (read# -# 1#)) `thenPrimIO` \ () -> + return (StringBuffer a# read# 0# 0#) + +freeStringBuffer :: StringBuffer -> IO () +freeStringBuffer (StringBuffer a# _ _ _) = + _casm_ `` free((char *)%0); '' (A# a#) `thenPrimIO` \ () -> + return () + +unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer +unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# = + unsafePerformPrimIO ( + _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) `thenPrimIO` \ () -> + returnPrimIO s) + +\end{code} + +Lookup + +\begin{code} +currentChar# :: StringBuffer -> Char# +currentChar# (StringBuffer fo# _ _ current#) = indexCharOffAddr# fo# current# + +currentChar :: StringBuffer -> Char +currentChar sb = case currentChar# sb of c -> C# c + +indexSBuffer# :: StringBuffer -> Int# -> Char# +indexSBuffer# (StringBuffer fo# _ _ _) i# = indexCharOffAddr# fo# i# + +indexSBuffer :: StringBuffer -> Int -> Char +indexSBuffer sb (I# i#) = case indexSBuffer# sb i# of c -> C# c + + -- relative lookup, i.e, currentChar = lookAhead 0 +lookAhead# :: StringBuffer -> Int# -> Char# +lookAhead# (StringBuffer fo# _ _ c#) i# = indexCharOffAddr# fo# (c# +# i#) + +lookAhead :: StringBuffer -> Int -> Char +lookAhead sb (I# i#) = case lookAhead# sb i# of c -> C# c + +\end{code} + + moving the start point of the current lexeme. + +\begin{code} + -- moving the end point of the current lexeme. +setCurrentPos# :: StringBuffer -> Int# -> StringBuffer +setCurrentPos# (StringBuffer fo l# s# c#) i# = + StringBuffer fo l# s# (c# +# i#) + +-- augmenting the current lexeme by one. +incLexeme :: StringBuffer -> StringBuffer +incLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#) + +decLexeme :: StringBuffer -> StringBuffer +decLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#) + +\end{code} + +-- move the start and end point of the buffer on by +-- x units. + +\begin{code} +stepOn :: StringBuffer -> StringBuffer +stepOn (StringBuffer fo l# s# c#) = StringBuffer fo l# (s# +# 1#) (s# +# 1#) -- assume they're the same. + +stepOnBy# :: StringBuffer -> Int# -> StringBuffer +stepOnBy# (StringBuffer fo# l# s# c#) i# = + case s# +# i# of + new_s# -> StringBuffer fo# l# new_s# new_s# + +-- jump to pos. +stepOnTo# :: StringBuffer -> Int# -> StringBuffer +stepOnTo# (StringBuffer fo l _ _) s# = StringBuffer fo l s# s# + +stepOnUntil :: (Char -> Bool) -> StringBuffer -> StringBuffer +stepOnUntil pred (StringBuffer fo l# s# c#) = + loop c# + where + loop c# = + case indexCharOffAddr# fo c# of + ch# | pred (C# ch#) -> StringBuffer fo l# c# c# + | otherwise -> loop (c# +# 1#) + +stepOverLexeme :: StringBuffer -> StringBuffer +stepOverLexeme (StringBuffer fo l s# c#) = StringBuffer fo l c# c# + +expandWhile :: (Char -> Bool) -> StringBuffer -> StringBuffer +expandWhile pred (StringBuffer fo l# s# c#) = + loop c# + where + loop c# = + case indexCharOffAddr# fo c# of + ch# | pred (C# ch#) -> loop (c# +# 1#) + | otherwise -> StringBuffer fo l# s# c# + + +scanNumLit :: Int -> StringBuffer -> (Int,StringBuffer) +scanNumLit (I# acc#) (StringBuffer fo l# s# c#) = + loop acc# c# + where + loop acc# c# = + case indexCharOffAddr# fo c# of + ch# | isDigit (C# ch#) -> loop (acc# *# 10# +# (ord# ch# -# ord# '0'#)) (c# +# 1#) + | otherwise -> (I# acc#,StringBuffer fo l# s# c#) + + +expandUntilMatch :: StringBuffer -> String -> StringBuffer +expandUntilMatch (StringBuffer fo l# s# c#) str = + loop c# str + where + loop c# [] = StringBuffer fo l# s# c# + loop c# ((C# x#):xs) = + if indexCharOffAddr# fo c# `eqChar#` x# then + loop (c# +# 1#) xs + else + loop (c# +# 1#) str +\end{code} + +\begin{code} + -- at or beyond end of buffer? +bufferExhausted :: StringBuffer -> Bool +bufferExhausted (StringBuffer fo l# _ c#) = c# >=# l# + +emptyLexeme :: StringBuffer -> Bool +emptyLexeme (StringBuffer fo l# s# c#) = s# ==# c# + + -- matching +prefixMatch :: StringBuffer -> String -> Maybe StringBuffer +prefixMatch (StringBuffer fo l# s# c#) str = + loop c# str + where + loop c# [] = Just (StringBuffer fo l# s# c#) + loop c# ((C# x#):xs) = + if indexCharOffAddr# fo c# `eqChar#` x# then + loop (c# +# 1#) xs + else + Nothing + +untilEndOfString# :: StringBuffer -> StringBuffer +untilEndOfString# (StringBuffer fo l# s# c#) = + loop c# + where + loop c# = + case indexCharOffAddr# fo c# of + '\"'# -> + case indexCharOffAddr# fo (c# -# 1#) of + '\\'# -> --escaped, false alarm. + loop (c# +# 1#) + _ -> StringBuffer fo l# s# c# + _ -> loop (c# +# 1#) + + +untilEndOfChar# :: StringBuffer -> StringBuffer +untilEndOfChar# (StringBuffer fo l# s# c#) = + loop c# + where + loop c# = + case indexCharOffAddr# fo c# of + '\''# -> + case indexCharOffAddr# fo (c# -# 1#) of + '\\'# -> --escaped, false alarm. + loop (c# +# 1#) + _ -> StringBuffer fo l# s# c# + _ -> loop (c# +# 1#) + +untilChar# :: StringBuffer -> Char# -> StringBuffer +untilChar# (StringBuffer fo l# s# c#) x# = + loop c# + where + loop c# = + if indexCharOffAddr# fo c# `eqChar#` x# then + StringBuffer fo l# s# c# + else + loop (c# +# 1#) + + -- conversion +lexemeToString :: StringBuffer -> String +lexemeToString (StringBuffer fo _ start_pos# current#) = + if start_pos# ==# current# then + "" + else + byteArrayToString (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#))) + + +lexemeToByteArray :: StringBuffer -> _ByteArray Int +lexemeToByteArray (StringBuffer fo _ start_pos# current#) = + if start_pos# ==# current# then + error "lexemeToByteArray" + else + copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)) + +lexemeToFastString :: StringBuffer -> FastString +lexemeToFastString (StringBuffer fo l# start_pos# current#) = + if start_pos# ==# current# then + mkFastCharString2 (A# fo) (I# 0#) + else + mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#)) + +{- + Create a StringBuffer from the current lexeme, and add a sentinel + at the end. Know What You're Doing before taking this function + into use.. +-} +lexemeToBuffer :: StringBuffer -> StringBuffer +lexemeToBuffer (StringBuffer fo l# start_pos# current#) = + if start_pos# ==# current# then + StringBuffer fo 0# start_pos# current# -- an error, really. + else + unsafeWriteBuffer (StringBuffer fo (current# -# start_pos#) start_pos# start_pos#) + (current# -# 1#) + '\NUL'# + +\end{code} diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index aaf4be1c20..bb06487f1d 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -3,7 +3,8 @@ Things which are ubiquitous in the GHC compiler. \begin{code} interface Ubiq where -import PreludePS(_PackedString) +--import PreludePS(_PackedString) +import FastString(FastString) import Bag ( Bag ) import BinderInfo ( BinderInfo ) @@ -132,7 +133,7 @@ data Unique -- NB: fails the optimisation criterion -- don't get clever and unexpand some of these synonyms -- (GHC 0.26 will barf) -type Module = _PackedString +type Module = FastString type Arity = Int type Class = GenClass (GenTyVar (GenUsage Unique)) Unique type ClassOp = GenClassOp (GenType (GenTyVar (GenUsage Unique)) Unique) diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 8f9e9f907a..52426d3d7b 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -49,6 +49,9 @@ module UniqFM ( lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, ufmToList +#if defined(COMPILING_GHC) + ,FAST_STRING +#endif ) where #if defined(COMPILING_GHC) @@ -813,12 +816,7 @@ shiftR_ n p = n `quot` (2 ^ p) #endif {- not GHC -} \end{code} -Andy's extras: ToDo: to Util. - \begin{code} -use_fst :: a -> b -> a -use_fst a b = a - use_snd :: a -> b -> b use_snd a b = b \end{code} diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs index aa0f7536ed..3b0b912cd5 100644 --- a/ghc/compiler/utils/Unpretty.lhs +++ b/ghc/compiler/utils/Unpretty.lhs @@ -82,7 +82,7 @@ uppPutStr :: Handle -> Int -> Unpretty -> IO () \begin{code} uppShow _ p = cShow p -uppPutStr f _ p = cPutStr f p +uppPutStr f _ p = _scc_ "uppPutStr" (cPutStr f p) uppNil = cNil uppStr s = cStr s diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 6d51f3aaf2..21e4589ad0 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -71,7 +71,7 @@ module Util ( -- comparisons #if defined(COMPILING_GHC) Ord3(..), thenCmp, cmpList, - cmpPString, + cmpPString, FAST_STRING, #else cmpString, #endif @@ -735,7 +735,7 @@ cmpString _ _ = error "cmpString" cmpPString :: FAST_STRING -> FAST_STRING -> TAG_ cmpPString x y - = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } + = case (tagCmpFS x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } \end{code} %************************************************************************ diff --git a/ghc/docs/Makefile b/ghc/docs/Makefile index f9d5e0c81e..2f99b93e63 100644 --- a/ghc/docs/Makefile +++ b/ghc/docs/Makefile @@ -1,6 +1,11 @@ -TOP = ../.. -include $(TOP)/ghc/mk/ghc.mk +TOP = .. +include $(TOP)/mk/boilerplate.mk + +# +# No ways and export this piece of config info downwards. +# +export WAYS= SUBDIRS = users_guide install_guide release_notes state_interface -include $(TOP)/mk/subdir.mk +include $(TOP)/mk/target.mk diff --git a/ghc/docs/install_guide/Makefile b/ghc/docs/install_guide/Makefile deleted file mode 100644 index d897cc6f9c..0000000000 --- a/ghc/docs/install_guide/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -TOP = ../../.. -LiterateSuffixRules = YES -DocProcessingSuffixRules = YES -include $(TOP)/ghc/mk/ghc.mk -#TARGETS = installing.texi installing.dvi diff --git a/ghc/docs/install_guide/installing.lit b/ghc/docs/install_guide/installing.lit deleted file mode 100644 index 19c5755153..0000000000 --- a/ghc/docs/install_guide/installing.lit +++ /dev/null @@ -1,2177 +0,0 @@ -% -% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/install_guide/Attic/installing.lit,v 1.5 1997/01/17 00:33:19 simonpj Exp $ -% -\begin{onlystandalone} -\documentstyle[11pt,literate]{article} -\begin{document} -\title{Installing the Glasgow Functional Programming Tools\\ -Version~2.01} -\author{The GHC Team\\ -Department of Computing Science\\ -University of Glasgow\\ -Glasgow, Scotland\\ -G12 8QQ\\ -\\ -Email: glasgow-haskell-\{users,bugs\}\@dcs.gla.ac.uk} -\maketitle -\begin{rawlatex} -\tableofcontents -\end{rawlatex} -\clearpage -\end{onlystandalone} - -%************************************************************************ -%* * -\section[install-intro]{Introduction} -%* * -%************************************************************************ - -For most people, it should be easy to install one or more of the -Glasgow functional-programming tools (the `Glasgow tools'), most often -just the Glasgow Haskell compiler (GHC). This document will guide you -through the installation process, and point out the known pitfalls. - -%************************************************************************ -%* * -\subsection[install-strategy]{What to install? Starting from what?} -%* * -%************************************************************************ - -Building the Glasgow tools {\em can} be complicated, mostly because -there are so many permutations of what/why/how, e.g., ``Build Happy -with HBC, everything else with GHC, leave out profiling, and test it -all on the `real' NoFib programs.'' Yeeps! - -Happily, such complications don't apply to most people. A few common -``strategies'' serve most purposes. Pick one and proceed -as suggested: -\begin{description} -\item[Install from binary ``bundles'':] You have one of the supported -platforms (e.g., Sun4 or DEC Alpha), and you just want a Haskell -compiler, and you don't want to do anything fancy... This choice -is for you. Proceed to -\sectionref{installing-bin-distrib}. HIGHLY RECOMMENDED! - -\item[Build some Glasgow tools using GHC itself:] You have a supported -platform, but (a)~you like the warm fuzzy feeling of compiling things -yourself; (b)~you want to build something ``extra''---e.g., a set of -libraries with strictness-analysis turned off; or (c)~you want to hack -on GHC yourself. - -In this case, you should install a binary distribution -(as described in \sectionref{installing-bin-distrib}), -then build GHC with it (as described in \sectionref{building-GHC}). - -\item[Build GHC from intermediate C \tr{.hc} files:] You cannot get a -pre-built GHC, so you have no choice but to ``bootstrap'' up from the -intermediate C (\tr{.hc}) files that we provide. -Building GHC on an unsupported platform falls into this category. -Please see \sectionref{booting-from-C}. - -NB: For GHC~2.01, bootstrapping from \tr{.hc} files means you will get -an all-2.01 system---possibly unduly slow. Building with GHC~0.29 -will get you a faster compiler... - -Once you have built GHC, you can build the other Glasgow tools with -it. - -\item[Build GHC with another Haskell compiler (e.g., HBC):] Not -recommended, but see \sectionref{building-with-HBC}. -\end{description} - -%************************************************************************ -%* * -\subsection[port-info]{What machines the Glasgow tools, version~2.01, run on} -\index{ports, GHC} -\index{GHC ports} -\index{supported platforms} -\index{platforms, supported} -%* * -%************************************************************************ - -The main question is whether or not the Haskell compiler (GHC) runs on -your machine. - -Bear in mind that certain ``bundles'', e.g. parallel Haskell, may not -work on all machines for which basic Haskell compiling is supported. - -Some libraries may only work on a limited number of platforms; for -example, a sockets library is of no use unless the operating system -supports the underlying BSDisms. - -%************************************************************************ -%* * -\subsubsection{What machines the Haskell compiler (GHC) runs on} -%* * -%************************************************************************ -\index{fully-supported platforms} -\index{native-code generator} -\index{registerised ports} -\index{unregisterised ports} - -The GHC hierarchy of Porting Goodness: (a)~Best is a native-code -generator; (b)~next best is a ``registerised'' -port; (c)~the bare minimum is an ``unregisterised'' port. -``Unregisterised'' is so terrible that we won't say more about it. - -We use Sun4s running SunOS~4.1.3 and Solaris 2.5, and DEC~Alphas -running OSF/1~V2.0, so those are the ``fully-supported'' platforms, -unsurprisingly. Both have native-code generators, for quicker -compilations. The native-code generator for iX86 platforms (e.g., -Linux ELF) is {\em nearly} working; but is not turned on by default. - -Here's everything that's known about GHC ports, as of 2.01. We -identify platforms by their ``canonical GNU-style'' names. - -Note that some ports are fussy about which GCC version you use; or -require GAS; or ... - -\begin{description} -%------------------------------------------------------------------- -\item[\tr{alpha-dec-osf1}:] -\index{alpha-dec-osf1: fully supported} -(We have OSF/1 V2.0.) Fully supported, including native-code generator. -We recommend GCC 2.6.x or later. - -%------------------------------------------------------------------- -\item[\tr{sparc-sun-sunos4}:] -\index{sparc-sun-sunos4: fully supported} -Fully supported, including native-code generator. - -%------------------------------------------------------------------- -\item[\tr{sparc-sun-solaris2}:] -\index{sparc-sun-solaris2: fully supported} -Fully supported, including native-code generator. A couple of quirks, -though: (a)~the profiling libraries are bizarrely huge; (b)~the -default \tr{xargs} program is atrociously bad for building GHC -libraries (see \sectionref{Pre-supposed} for details). - -%------------------------------------------------------------------- -\item[HP-PA box running HP/UX 9.x:] -\index{hppa1.1-hp-hpux: registerised port} -Works registerised. No native-code generator. -For GCC, you're best off with one of the Utah releases of -GCC~2.6.3 (`u3' or later), from \tr{jaguar.cs.utah.edu}. -We think a straight GCC 2.7.x works, too. - -Concurrent/Parallel Haskell probably don't work (yet). -\index{hppa1.1-hp-hpux: concurrent---no} -\index{hppa1.1-hp-hpux: parallel---no} - -%------------------------------------------------------------------- -\item[\tr{i386-*-linux} (PCs running Linux---ELF format):] -\index{i386-*-linux: registerised port} -GHC~2.01 works registerised. -You {\em must} have GCC 2.7.x or later. -The iX86 native-code generator is {\em nearly} there, but it -isn't turned on by default. - -Profiling works, and Concurrent Haskell works. -\index{i386-*-linux: profiling---yes} -\index{i386-*-linux: concurrent---yes} -Parallel Haskell probably works. -\index{i386-*-linux: parallel---maybe} - -On old Linux a.out systems: should be the same. -\index{i386-*-linuxaout: registerised port} - -%------------------------------------------------------------------- -\item[\tr{mips-sgi-irix5}:] -\index{mips-sgi-irix5: registerised port} -GHC~2.01 works registerised (no native-code generator). -I suspect any GCC~2.6.x (or later) is OK. The GCC that I used -was built with \tr{--with-gnu-as}; turns out that is important! - -Concurrent/Parallel Haskell probably don't work (yet). -Profiling might work, but it is untested. -\index{mips-sgi-irix5: concurrent---no} -\index{mips-sgi-irix5: parallel---no} -\index{mips-sgi-irix5: profiling---maybe} - -%------------------------------------------------------------------- -\item[\tr{m68k-apple-macos7} (Mac, using MPW):] -\index{m68k-apple-macos7: historically ported} -Once upon a time, David Wright in Tasmania has actually -gotten GHC to run on a Macintosh. Ditto James Thomson here at Glasgow. -You may be able to get Thomson's from here. (Not sure that it will -excite you to death, but...) - -No particularly recent GHC is known to work on a Mac. - -%------------------------------------------------------------------- -\item[\tr{m68k-next-nextstep3}:] -\index{m68k-next-nextstep3: historically ported} -Carsten Schultz succeeded with a ``registerised'' port of GHC~0.19. -There's probably a little bit-rot since then, but otherwise it should -still be fine. Had a report that things were basically OK at 0.22. - -Concurrent/Parallel Haskell probably won't work (yet). -\index{m68k-next-nextstep3: concurrent---no} -\index{m68k-next-nextstep3: parallel---no} - -%------------------------------------------------------------------- -\item[\tr{m68k-sun-sunos4} (Sun3):] -\index{m68k-sun-sunos4: registerised port} -GHC~2.01 hasn't been tried on a Sun3. GHC~0.26 worked registerised. -No native-code generator. - -Concurrent/Parallel Haskell probably don't work (yet). -\index{m68k-sun-sunos4: concurrent---no} -\index{m68k-sun-sunos4: parallel---no} -\end{description} - -%************************************************************************ -%* * -\subsubsection{What machines the other tools run on} -%* * -%************************************************************************ - -Unless you hear otherwise, the other tools work if GHC works. - -Haggis requires Concurrent Haskell to work. -\index{Haggis, Concurrent Haskell} - -%************************************************************************ -%* * -\subsection{Things to check before you start typing} -%* * -%************************************************************************ - -\begin{enumerate} -\item -\index{disk space needed} -Disk space needed: About 30MB (five hamburgers' worth) of disk space -for the most basic binary distribution of GHC; more for some -platforms, e.g., Alphas. An extra ``bundle'' (e.g., concurrent -Haskell libraries) might take you to 8--10 hamburgers. - -You'll need over 100MB (say, 20 hamburgers' worth) if you need to -build the basic stuff from scratch. - -I don't yet know the disk requirements for the non-GHC tools. - -All of the above are {\em estimates} of disk-space needs. - -\item -Use an appropriate machine, compilers, and things. - -SPARC boxes and DEC Alphas running OSF/1 are fully supported. -Linux, MIPS, and HP boxes are in pretty good shape. -\Sectionref{port-info} gives the full run-down on ports or lack -thereof. - -\item -Be sure that the ``pre-supposed'' utilities are installed. - -For GHC, you must have \tr{perl} to get anywhere at all. If you're -going for Parallel Haskell, you'll need PVM, version 3. You will -probably need a reasonably up-to-date GCC (GNU C compiler), -too---\sectionref{port-info} lists any specific requirements in this -regard. - -% If you are going to be making documents [unlikely], you'll need -% \tr{makeindex} as well, and maybe \tr{tgrind} [unlikely]. If you edit -% the one or two \tr{flex} files in GHC, you'll need \tr{flex}, too -% [unlikely]. -% -If you end up yacc'ing the Haskell parser [unlikely], Sun's standard -\tr{/bin/yacc} won't cut it. Either the unbundled \tr{/usr/lang/yacc} -or \tr{bison} will do fine. Berkeley yacc (\tr{byacc}) won't do. - -\item -If you have any problem when building or installing the Glasgow tools, -please check the ``known pitfalls'' (\sectionref{build-pitfalls}). If -you feel there is still some shortcoming in our procedure or -instructions, please report it. - -For GHC, please see the bug-reporting section of the User's guide -(separate document), to maximise the usefulness of your report. - -If in doubt, please send a message to -\tr{glasgow-haskell-bugs@dcs.gla.ac.uk}. -\end{enumerate} - -%************************************************************************ -%* * -\section[installing-bin-distrib]{Installing from binary distributions (the most common case)} -\index{binary installations} -\index{installation, of binaries} -%* * -%************************************************************************ - -Installing from binary distributions is easiest, and recommended! - -%************************************************************************ -%* * -\subsection[GHC-bin-distrib]{GHC from binary distributions} -\index{GHC installation, from binaries} -\index{installation, GHC from binaries} -%* * -%************************************************************************ - -(Why binaries? Because GHC is a Haskell compiler written in Haskell, -so you've got to ``bootstrap'' it, somehow. We provide -machine-generated C-files-from-Haskell for this purpose, but it's -really quite a pain to use them. If you must build GHC from its -sources, using a binary-distributed GHC to do so is a sensible way to -proceed.) - -Binary distributions come in ``bundles,''\index{bundles of binary stuff} -one bundle per \tr{.tar.gz} file. - -A basic GHC ``bundle'' gives you the compiler and the standard, -sequential libraries. The files are called -\tr{ghc-2.01-<platform>.tar.gz}, where \tr{<platform>} is one of: -alpha-dec-osf2, hppa1.1-hp-hpux9, i386-unknown-linux, -i386-unknown-solaris2, i386-unknown-freebsd, -m68k-sun-sunos4, mips-sgi-irix5, -sparc-sun-sunos4, sparc-sun-solaris2. - -There are plenty of ``non-basic'' GHC bundles. The files for them are -called \tr{ghc-2.01-<bundle>-<platform>.tar.gz}, where the -\tr{<platform>} is as above, and \tr{<bundle>} is one of these: -\begin{description} -\item[\tr{prof}:] Profiling with cost-centres. You probably want this. - -\item[\tr{conc}:] Concurrent Haskell features. You may want this. - -\item[\tr{par}:] Parallel Haskell features (sits on top of PVM). -You'll want this if you're into that kind of thing. - -\item[\tr{gran}:] The ``GranSim'' parallel-Haskell simulator -(hmm... mainly for implementors). - -\item[\tr{ticky}:] ``Ticky-ticky'' profiling; very detailed -information about ``what happened when I ran this program''---really -for implementors. - -\item[\tr{prof-conc}:] Cost-centre profiling for Concurrent Haskell. - -\item[\tr{prof-ticky}:] Ticky-ticky profiling for Concurrent Haskell. -\end{description} - -One likely scenario is that you will grab {\em three} binary -bundles---basic, profiling, and concurrent. Once you have them, -unpack them all together in the same place, thusly: - -\begin{verbatim} -cd /put/them/in/here -gunzip < ghc-2.01-sparc-sun-sunos4.tar.gz | tar xf - -gunzip < ghc-2.01-prof-sparc-sun-sunos4.tar.gz | tar xf - -gunzip < ghc-2.01-conc-sparc-sun-sunos4.tar.gz | tar xf - -\end{verbatim} - -If you unpacked the files in a way that does {\em not} preserve -modification times (e.g., used the \tr{m} option to \tr{tar}---why on -earth you might do this, I cannot imagine), then please unpack them -again :-) The timestamps on the files are (regrettably) important. - -%To check that you have all the pre-supposed utilities, please see -%\sectionref{Pre-supposed}. - -Here's what to do with the stuff in each directory, once unpacked. -% (If your binary distribution, doesn't look like this---don't despair! -% It may be a ``dumped-from-a-build'' distribution; please see -% \sectionref{dumped-from-build}.) - -\begin{description} -%--------------------------------------------------------------------- -\item[\tr{bin/<platform>} (sometimes just \tr{bin/}):] -Copy (or link to) these executables so that they will be in users' PATHs. - -%--------------------------------------------------------------------- -\item[\tr{lib}:] -Move this directory, in toto, to wherever you want it to live. -It should still be called \tr{lib}. - -%--------------------------------------------------------------------- -\item[\tr{docs}:] -This is the full \tr{docs} tree. Just follow the normal instructions, -in \sectionref{make-docs}. -\end{description} - -Things you need to fiddle so the tools will spring to life: -\begin{enumerate} -\item -\tr{rehash} (csh users), so your shell will see the new stuff in your -bin directory. - -\item -Edit your \tr{ghc}, \tr{mkdependHS}, and \tr{hstags} scripts: -(a)~Create a correct \tr{#!...perl} first line in each one. (Ask a -Unix-friendly person to help you, if you don't know what a -\tr{#!}-line is.) (b) Find the line that looks something like: -\begin{verbatim} -# $ENV{'GLASGOW_HASKELL_ROOT'} = '/some/absolute/path/name'; -\end{verbatim} -Remote the comment symbol (\tr{#}) on the front, and change the -path name to be the right thing. - -So, if your ``lib'' files are now in \tr{/home/myself/lib/ghc/...}, -then you should set \tr{GLASGOW_HASKELL_ROOT} to \tr{/home/myself}. - -\item -Actually setting the \tr{GLASGOW_HASKELL_ROOT} environment variable -is a {\em bad} idea, mostly because it precludes having several -GHC versions around at the same time. - -% \item -% CHOICE \#2: -% Set your \tr{GLASGOW_HASKELL_ROOT} environment variable, and -% don't edit the \tr{ghc}, \tr{mkdependHS}, and \tr{hstags} scripts -% at all. -% -% It's better to edit the scripts; that way, it's once for all. - -\item -You {\em may} need to re-\tr{ranlib} your libraries (on Sun4s). -\begin{verbatim} -% cd <wherever-the-lib-files-are-now>/ghc/2.01/sparc-sun-sunos4 -% foreach i ( `find . -name '*.a' -print` ) # or other-shell equiv... -? ranlib $i -? # or, on some machines: ar s $i -? end -\end{verbatim} - -\item -Once done, test your ``installation'' as suggested in -\sectionref{GHC_test}. Be sure to use a \tr{-v} option, so you -can see exactly what pathnames it's using. - -If things don't work, double-check your hand-edited path -names. Things will go catastrophically wrong as long as they are -incorrect. -\end{enumerate} - -%************************************************************************ -%* * -\subsection[non-GHC-bin-distrib]{Other tools from binary distributions} -%* * -%************************************************************************ - -NOT DONE YET. - -All of the above is for GHC bundles. For other tools, the same -principles apply: get the binary bundles you want, then unpack them -all together in the same place. - -%************************************************************************ -%* * -%\subsection[dumped-from-build]{Installing a ``dumped-from-build'' binary distribution (some platforms)} -%* * -%************************************************************************ -%#% -%#% Sometimes, a binary distribution is taken directly from a GHC -%#% ``build.'' An example is the Solaris distribution. You can tell from -%#% the layout of the files. -%#% -%#% The setup required is nearly the same as a ``regular'' binary -%#% distribution; only some names are different. -%#% \begin{enumerate} -%#% \item -%#% Get the user-executable scripts into your PATH, either by copying it -%#% or by linking to it. These are in: -%#% \begin{verbatim} -%#% <topdir>/ghc/driver/ghc -%#% <topdir>/ghc/utils/mkdependHS/mkdependHS -%#% <topdir>/ghc/utils/hstags/hstags -%#% \end{verbatim} -%#% -%#% \item -%#% Set the \tr{GLASGOW_HASKELL_ROOT} environment variable for the three -%#% scripts above, in the manner outlined in the previous section. -%#% -%#% \item -%#% Possibly re-\tr{ranlib}'ing your \tr{*.a} files: -%#% \begin{verbatim} -%#% % cd <topdir> -%#% % foreach i ( `find . -name '*.a' -print` ) # or other-shell equiv... -%#% % ranlib $i -%#% % # or, on some machines: ar s $i -%#% % end -%#% \end{verbatim} -%#% -%#% \item -%#% Don't forget to test it! -%#% \end{enumerate} - -%************************************************************************ -%* * -\section[checklist]{Building Glasgow tools from source: a checklist} -%* * -%************************************************************************ - -\begin{enumerate} -\item -Install any pre-supposed utility programs that you do not have at your -site. You have to do this ``by hand.'' It's not hard, and these are -things you want to have anyway. Please see \sectionref{Pre-supposed}. - -\item -Be sure you have a suitable Haskell compiler, or else the intermediate -C (\tr{.hc}) files.. -\Sectionref{install-strategy} lists the various strategies you might -adopt. - -If you don't have a Haskell compiler, the most painless option is to -use a binary-distributed GHC to compile Glasgow tools (including GHC -itself) from source. Installing a binary distribution (the first -step) is described in \sectionref{installing-bin-distrib}. - -\item -You might want to write-protect your source files at this point: -\begin{verbatim} -cd <the-very-top-dir> -find . -type f \! -name \*.hi \! -name \*.hc \! -name \*.jm -print \ - | xargs chmod a-w -\end{verbatim} - -\item -Run the \tr{configure} script. It is a shell script that looks around -to find out things about your system. You can see the \tr{configure} -options by passing it a \tr{--help} flag, or by reading -\sectionref{Configuring}. A typical invocation might be: -\begin{verbatim} -% cd <the-very-top-dir> -% ./configure --prefix=/usr/local/fp \ - --with-hc=ghc-0.29 --with-mkdependHS=mkdependHS-0.29 -\end{verbatim} - -\item -Once configured, build the basic support utilities and make your -Makefiles, including the automagically-created dependencies between -files. The near-universal incantation is: -\begin{verbatim} -% cd <the-very-top-dir> -% sh < STARTUP >& startup.log # and chk the log afterwards! -\end{verbatim} - -\item -Build the Glasgow tools you are interested in, as \tr{STARTUP} suggests: -\begin{verbatim} -% cd <the-very-top-dir>/<tool> -% make all >& make.log # time to go to lunch! -\end{verbatim} -Consult the list of known pitfalls (\sectionref{build-pitfalls}) if -something goes wrong. - -\item -Test what you've built, enough to know that it's working. - -\item -Actually install the tools, if you wish: -\begin{verbatim} -% cd <the-very-top-dir>/<tool> -% make install -\end{verbatim} - -\item -Make and/or install the documentation. - -\item -Save a copy of your \tr{config.status} file, for the next -even-more-wonderful release! - -\item -If you're finished, tidy up after yourself [\tr{make clean}], if you -want to. - -Alternatively, \tr{/bin/rm -rf <tool>} :-) -\end{enumerate} - -%************************************************************************ -%* * -\section[building-GHC]{Building the Glasgow Haskell Compiler (GHC)} -\index{GHC installation, from sources} -%* * -%************************************************************************ - -%************************************************************************ -%* * -\downsection -\section{Building GHC from source, compiling it with itself} -\index{building GHC with itself} -\index{booting GHC with itself} -%* * -%************************************************************************ - -This section describes how to build GHC from source. You would do -this if (a)~there is no ``canned'' binary distribution for your -machine, (b)~the binary distribution omits features that you want, -(c)~you want to make changes to GHC and them build them in, or -(d)~you like torturing yourself. - -This blow-by-blow description follows the general checklist in -\sectionref{checklist}. - -%************************************************************************ -%* * -\subsection[Right-compiler-and-files]{Do you have a suitable compiler and/or \tr{.hc} files and/or \tr{.hi} files?} -\index{booting GHC, files needed} -%* * -%************************************************************************ - -We now proceed through each installation step, carefully. - -Because the compiler heart of Glorious Glasgow Haskell is written in -Haskell, you have to use some ``bootstrapping'' mechanism. - -Your best choice, if available, is to use a binary distribution for -your platform; e.g., compile GHC~2.01 with a GHC~0.29 that we have -provided. Please see \sectionref{installing-bin-distrib} for how to -install a binary distribution. - -Your remaining choice is to use the intermediate C (\tr{.hc}) files -that we supply. This is the {\em only} choice for anyone trying to -port to a new or weakly-supported system. - -The main drawback of the supplied-\tr{.hc} approach is that you will -have a lot of very bulky intermediate files on your disk for a while. - -(With GHC~2.01, another drawback is that the \tr{.hc} files will give -you a 2.01-built-with-2.01---normally a good thing---but, in this case, -probably slower than a 2.01-built-with-0.29.) - -% If you have to boot from C (\tr{.hc}) files, you should follow the -% directions in \sectionref{booting-from-C}. - -% We also supply parts of the system pre-compiled to C (in \tr{.hc} -% files). This is partly to save you work (you don't have to wait for -% them to compile yourself) and partly because this is how we will -% eventually supply the self-compiling compiler (when that's ready). -% In any case, if you slurped the \tr{.tar.gz} file, you should, {\em in -% the same directory as before}, do... -% \begin{verbatim} -% % gunzip -c ghc-<version>-hc-files.tar.gz | tar xfv - -% \end{verbatim} - -%************************************************************************ -%* * -\subsection{Write-protecting your source files} -\index{write-protecting source files} -%* * -%************************************************************************ - -At this point, some people like to write-protect their source files against -inadvertent change: -\begin{verbatim} -cd <very-top-dir> -find . -type f \! -name '*.hi' \! -name \*.hc \! -name '*.jm' -print \ - | xargs chmod a-w -\end{verbatim} - -%************************************************************************ -%* * -\subsection{Running \tr{configure} and \tr{STARTUP} for GHC} -\index{configure, for GHC} -\index{STARTUP, for GHC} -%* * -%************************************************************************ - -The \tr{configure} script finds out things about your machine. It -also allows you to specify features to include/exclude from your GHC -installation. - -Please see \sectionref{Configuring} for all about \tr{configure}, and -\sectionref{Configuring-GHC} for details of GHC configuring (including -examples). - -Once \tr{configure} runs successfully, do as it says and do -\tr{sh < STARTUP}. - -%************************************************************************ -%* * -\subsection{Build the compiler!} -\index{make all, for GHC} -%* * -%************************************************************************ - -Do the main GHC build, just as \tr{STARTUP} suggests: -\begin{verbatim} -% cd ghc -% make all >& make.log -% cd ../hslibs -% make all >& make.log -\end{verbatim} -If this fails or something seems suspicious, check the ``known -pitfalls'' (\sectionref{build-pitfalls}). If you can't figure out how -to proceed, please get in touch with us. - -If you have to restart the build, for whatever reason, you are just as -well to make the whole thing; i.e., re-do as described above. (Well, -the \tr{compiler} and \tr{lib} subdirectories are the last two; if the -build ``dies'' in one of them, it is usually safe to finish the job by -hand.) - -%************************************************************************ -%* * -\subsection[GHC_test]{Test that GHC seems to be working} -\index{testing a new GHC} -%* * -%************************************************************************ - -The way to do this is, of course, to compile and run {\em this} program -(in a file \tr{Main.hs}): -\begin{verbatim} -main = putStr "Hello, world!\n" -\end{verbatim} - -First, give yourself a convenient way to execute the driver script -\tr{ghc/driver/ghc}, perhaps something like... -\begin{verbatim} -% ln -s /local/src/ghc-2.01/ghc/driver/ghc ~/bin/alpha/ghc -% rehash -\end{verbatim} - -Compile the program, using the \tr{-v} (verbose) flag to verify that -libraries, etc., are being found properly: -\begin{verbatim} -% ghc -v -o hello Main.hs -\end{verbatim} - -Now run it: -\begin{verbatim} -% ./hello -Hello, world! -\end{verbatim} - -Some simple-but-profitable tests are to compile and run the -notorious \tr{nfib} program, using different numeric types. Start -with \tr{nfib :: Int -> Int}, and then try \tr{Integer}, \tr{Float}, -\tr{Double}, \tr{Rational} and maybe \tr{Complex Float}. Code -for this is distributed in \tr{ghc/misc/examples/nfib/}. - -For more information on how to ``drive'' GHC, -either do \tr{ghc -help} or consult the User's Guide (distributed in -\tr{ghc/docs/users_guide}). - -%************************************************************************ -%* * -\subsection[GHC_install]{Actually installing GHC} -\index{make install, GHC} -\index{installing, GHC} -%* * -%************************************************************************ - -``Installing GHC'' means copying the files required to run it to their -``permanent home.'' You can then delete, or at least tidy up, your -source directory. - -If you have no reason to install GHC, you can execute directly out of -the source tree, as sketched in the section above -(\sectionref{GHC_test}). - -Assuming that everything's OK so far, all you need to do is: -\begin{verbatim} -% cd <very-top>/ghc -% make install -% cd <very-top>/hslibs -% make install -\end{verbatim} - -If you're a little dubious (as I usually am), you can always do a -``trial run'' first: -\begin{verbatim} -% cd <very-top>/ghc -% make -n install >& temp-log-file-to-look-at -% cd <very-top>/hslibs -% make -n install >& temp-log-file-to-look-at -\end{verbatim} - -In both cases, if something breaks, it's a {\em bug}. - - -%************************************************************************ -%* * -\subsection[make-docs]{Installing the GHC documentation (optional)} -\index{documentation, making} -\index{make docs, GHC} -\index{installing documentation} -%* * -%************************************************************************ - -Because our documentation is in DVI/Info/HTML formats, and because there is -no standard practice about how such documents are ``installed,'' we -haven't tried to automate this (at least not enough that we promise it -works). - -You can find all the documentation in the distribution with: -\begin{verbatim} -% cd ghc/docs -% find . \( -name '*.dvi' -o -name '*.info' -o -name '*.html' \) -print -\end{verbatim} - -If you have a standard place to put such files, just copy -them there. (Better ideas welcome.) - -The following ``man'' pages are hidden around in the distribution: -\begin{verbatim} -ghc/utils/hp2ps/hp2ps.1 -literate/info-utils/info.1 -glafp-utils/scripts/mkdirhier.man -glafp-utils/scripts/lndir.man -\end{verbatim} -Please install them by hand if you need to. - -%There are various pieces of GHC whose code can be formatted -%``literately.'' The usual procedure is... -%\begin{verbatim} -%% cd ghc/<wherever> -%% make depend # VERY IMPORTANT for literate docs! -%% make docs # or more directly.... -%% make whatever.dvi # or, for Info freaks,... -%% make whatever.info -%\end{verbatim} - -%For ``chunks'' of the compiler proper, in \tr{ghc/compiler}, you will -%need to make a \tr{Makefile} for them first: -%\begin{verbatim} -%cd ghc/compiler -%make Makefile SUBDIRS=prelude # for example... -%cd prelude -%make depend # i.e., as before -%make prelude.dvi -%\end{verbatim} -%Directories for which this {\em might} (I emphasize: `MIGHT') work are ... -%\begin{verbatim} -%codeGen/Jmakefile -%coreSyn/Jmakefile -%deSugar/Jmakefile -%podizeCore/Jmakefile -%prelude/Jmakefile -%typecheck/Jmakefile -%\end{verbatim} -% -%Remember: an unpatched perl 4.035 will {\em crash} on making many of -%our ``literate'' Info files. (The current version, 4.036, will not.) - -%$$ Note: Because we make our Info files by going through Texinfo format, -%$$ you can use \tr{texi2html} to produce HTML files. A -%$$ minisculely-hacked version is in the distribution in -%$$ \tr{literate/texi2html/texi2html}. - -%************************************************************************ -%* * -\subsection[clean-up]{Cleaning up after yourself} -\index{make clean, GHC} -\index{cleaning up afterwards} -%* * -%************************************************************************ - -\tr{make clean} is the basic command to tidy things up. However: if -you do this, {\em you will not be able to execute directly out of the -source tree thereafter!} (as sketched in \sectionref{GHC_test}). Nor will -you be able to make documents, etc.---you would have to re-build parts -of GHC first. - -If you want to execute out of the source tree but would like to clear -off lots and lots of stuff, you can do: -\begin{verbatim} -% cd ghc/lib # scrub library .hc and object files -% rm */*.hc */*.*_hc -% find . -name '*.o' -print | xargs /bin/rm - -% cd hslibs/ # ditto for syslibs -% rm */src/*.hc */src/*.*_hc - -% cd ghc/compiler # scrub compiler object files -% rm */*.o -% rm */*.hc # if you have been keeping them around -\end{verbatim} -(You can scrub the object files in \tr{ghc/runtime} similarly---except -\tr{main/TopClosure*.o}.) - -%\tr{make veryclean} is the command to clear off everything that can be -%safely cleared off. Not recommended (inadequately tested). - -%************************************************************************ -%* * -\section[booting-from-C]{Booting/porting from C (\tr{.hc}) files} -\index{building GHC from .hc files} -\index{booting GHC from .hc files} -%* * -%************************************************************************ - -This section is for people trying to get GHC going by using the -supplied intermediate C (\tr{.hc}) files. This would probably be -because no binaries have been provided, or because the machine -is not ``fully supported.'' - -To boot from C (\tr{.hc}) files, you need the regular source distribution -(\tr{ghc-2.01-src.tar.gz}) and also some extra files in -\tr{ghc-2.01-hc-files.tar.gz}. DON'T FORGET any extra \tr{.hc} -files for profiling, concurrent, parallel, ... - -Whatever you want to build, just unpack all the files ``together'': -\begin{verbatim} -% cd <wherever> -% gunzip -c ghc-2.01-src.tar.gz | tar xf - -% gunzip -c ghc-2.01-hc-files.tar.gz | tar xf - # basic... -% gunzip -c ghc-2.01-prof-hc-files.tar.gz | tar xf - # profiling... -% gunzip -c ghc-2.01-conc-hc-files.tar.gz | tar xf - # concurrent... -... etc ... -\end{verbatim} - -For the ``it's been tried before'' machines, the normal -configure/build procedure will probably work; just keep your eyes -peeled for mischief. - -WORD OF WISDOM: Be sure you have a suitable GCC (GNU C compiler); please -see \sectionref{port-info} for any specific requirements for your machine. - -You'll need plenty of disk space to do this whole procedure! - -%$$ %************************************************************************ -%$$ %* * -%$$ \subsection[boot-file-fiddling]{Unpack; then fiddle files before booting} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ Unpack the relevant files for booting as described above. -%$$ -%$$ If you are on a never-seen-before platform, then there is a little -%$$ machine-specific code/stuff scattered around the GHC files, which will -%$$ need to be updated before you get started. -%$$ -%$$ \begin{description} -%$$ %--------------------------------------------------------------------- -%$$ \item[Change \tr{configure}, so it recognizes your machine:] -%$$ Add the obvious stuff if it says ``Unrecognised platform for GHC.'' -%$$ -%$$ If you are teaching GHC how to ``registerise'' on a new platform, you -%$$ will also need to make sure the variable @GhcWithRegisterised@ is set -%$$ correctly. -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Change {\em two} copies of \tr{platform.h.in}:] -%$$ In the obvious way. They are in \tr{ghc/includes/} and \tr{mkworld/}. -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Floating-pointness:] -%$$ Grep for \tr{_TARGET} in \tr{ghc/includes/*.*h} and make suitable -%$$ adjustments. -%$$ -%$$ One change you will certainly make is in \tr{StgMacros.lh}, to decide -%$$ the inclusion of \tr{ieee-flpt.h} and \tr{BIGENDIAN}. -%$$ -%$$ Please use the CPP symbols defined in \tr{platform.h.in}! -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[64-bitness:] -%$$ Again, grepping for \tr{_TARGET} in \tr{ghc/includes/*.lh} will find -%$$ the places that need adjusting. \tr{GhcConstants.lh} and -%$$ \tr{StgTypes.lh} are two places that will need tweaking, for example. -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[``Registerizing'' magic:] -%$$ This is the platform-specific stuff in \tr{COptJumps.lh}, -%$$ \tr{COptWraps.lh}, and \tr{MachRegs.lh} in \tr{ghc/includes}. -%$$ -%$$ If you are doing an initial unregisterised boot for your platform, you -%$$ don't need to mess with these files at all. -%$$ -%$$ \Sectionref{real-version-from-init-boot} discusses how to get a -%$$ ``registerised'' version of GHC going. (Much trickier, but much -%$$ faster. [0.26: and the documentation is OUT-OF-DATE]) -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Host/target platforms in the driver:] -%$$ Grep for all occurrences of \tr{$HostPlatform} and \tr{$TargetPlatform} -%$$ in \tr{ghc/driver/*.lprl}. -%$$ -%$$ Don't worry about the \tr{process_asm_block} stuff in -%$$ \tr{ghc-split.lprl}. Not used in a straight ``unregisterised'' -%$$ version. -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Target-specific GCC flags in the driver:] -%$$ -%$$ The main thing to worry about in \tr{ghc.lprl} is the section on how -%$$ to ``Add on machine-specific C-compiler flags.'' -%$$ You may want to add something {\em vaguely} like: -%$$ \begin{verbatim} -%$$ ... -%$$ } elsif ($TargetPlatform =~ /^mips-dec-ultrix/) { -%$$ unshift(@CcBoth_flags, ('-G0', '-static')) if $GccAvailable; -%$$ \end{verbatim} -%$$ -%$$ Explanations: (1)~Static linking {\em tends} to give less problems, so -%$$ it is a reasonable choice for an initial attempt. -%$$ -%$$ (2)~In processing -%$$ the intermediate C (\tr{.hc}) files, you are compiling some {\em huge} -%$$ wads of C. Sadly, quite a few systems don't cope well with this, and -%$$ more than a few silently produce object files that won't link. GCC -%$$ usually provides some platform-specific flag that says ``generate code -%$$ that will work no matter how big the files are''. The \tr{-G0} for -%$$ DEC MIPS boxes is an example. If your system has such restrictions, -%$$ insert some magic {\em here}! -%$$ \end{description} - -%************************************************************************ -%* * -\subsection{Do \tr{configure}; \tr{sh < STARTUP}; \tr{cd ghc; make all}; test it!} -\index{configure, GHC with .hc files} -\index{make all, GHC with .hc files} -%* * -%************************************************************************ - -Go ahead and try \tr{configure}, as described \Sectionref{Configuring} -(GHC specifics in \Sectionref{Configuring-GHC}). - -The key \tr{configure} option is \tr{--with-hc=c}. A typical -going-via-C invocation might be: - -\begin{verbatim} -% ./configure --prefix=/local/fp --with-hc=c # basic + profiling -\end{verbatim} - -Other common possibilities might be: - -\begin{verbatim} -% ./configure --with-hc=c --disable-profiling # basic only - -% ./configure --with-hc=c --enable-concurrent --enable-parallel - # basic + profiling + concurrent + parallel -\end{verbatim} - -%$$ One likely reason it won't work is it will say it never heard of your -%$$ machine. Just edit the script and carry on! (As always, please send -%$$ us the changes.) - -Next, run \tr{STARTUP} in the usual way, as described in -\Sectionref{STARTUP}. - -It's now time to type \tr{cd ghc; make all}! This ``should'' work, -especially, on a known machine. Also, it can take a VERY long time -(esp. on oldish machines), so it's good to run overnight, on a quiet -machine, nice'd, etc., etc. - -You will probably continue by building the system libraries: -\tr{cd hslibs; make all}... - -When it's all built, test your alleged GHC system, as suggested in -\sectionref{GHC_test}. - -%$$ What you should end up with, built in this order: (1)~a runtime system -%$$ [\tr{ghc/runtime/libHSrts_ap.a}]; (2)~Prelude libraries -%$$ [\tr{ghc/lib/libHS_ap.a} and \tr{ghc/lib/libHShbc_ap.a}]; and (3)~a -%$$ compiler [\tr{ghc/compiler/hsc}] (which needs the first two). -%$$ -%$$ (Umm... if you are on a supported platform, but compiling via C, then -%$$ the \tr{*.a} suffixes will be \tr{_ap_o.a} (regular) and \tr{_p.a} -%$$ (profiling).) - -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection{A pre-emptive \tr{hello, world} test} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ On an unsupported platform, -%$$ You very well may want to {\em kill the compilation} once -%$$ \tr{libHSrts_ap.a} and \tr{libHS_ap.a} are built, to do a little -%$$ pre-emptive testing: time to run \tr{Hello, world!}. Using -%$$ \tr{ghc/CONTRIB/hello.hc}... -%$$ \begin{verbatim} -%$$ % .../ghc/driver/ghc -c -g hello.hc -%$$ % .../ghc/driver/ghc -v -o hello -g hello.o -%$$ % ./hello -%$$ \end{verbatim} -%$$ -%$$ If you have any trouble to do with ``consistency checking,'' just -%$$ avoid it, with the \tr{-no-link-chk} flag. -%$$ -%$$ If \tr{hello} crashes/breaks, it's time for Ye Olde Debugger, or -%$$ perhaps Ye Older Cry for Help... -%$$ -%$$ If things are OK and if you {\em did} kill the compilation, just re-do -%$$ \tr{make} to finish the job (build any other libraries, then the -%$$ compiler binary \tr{ghc/hsc}). -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[init-boot-hsc]{Finishing the initial boot} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ If you manage to get a \tr{ghc/hsc} binary (usually huge), then... -%$$ YOU HAVE A HASKELL COMPILER, albeit big and slow! So test it, -%$$ ``from the sources,'' before installing it: -%$$ \begin{verbatim} -%$$ % cat > test.hs -%$$ main = print ((10001 - 30002)::Integer) -%$$ -- or any other program(s) you want... -%$$ ^D -%$$ % .../ghc/driver/ghc -v -g -c test.hs -%$$ % .../ghc/driver/ghc -v -g -o test test.o -%$$ % ./test -%$$ \end{verbatim} -%$$ (Note how I fiendishly included a \tr{-g}, in case I had to throw a -%$$ debugger at it...) -%$$ -%$$ Of course, you {\em may not} have a \tr{ghc/hsc} binary---something -%$$ went wrong. The most likely cause is a compiler/assembler/linker -%$$ failure due to the HUGE size of this program. Please revisit the -%$$ discussion about this towards the end of -%$$ \sectionref{boot-file-fiddling}. Sadly, if you have to tweak -%$$ C-compiler/whatever flags, you may have to rebuild all the -%$$ libraries/compiler again; the following is sufficient to clear -%$$ off everything for a fresh start (NB: don't do \tr{make clean}): -%$$ \begin{verbatim} -%$$ % cd ghc/runtime # clear off RTS -%$$ % make clean SUBDIRS=foo # but avoid clearing GMP lib -%$$ % cd ../lib -%$$ % rm */*.o -%$$ % cd ../compiler -%$$ % rm */*.o -%$$ \end{verbatim} -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[installing-init-boot]{`Installing' the initial boot} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ If you are satisfied that things are working, {\em possibly install} the -%$$ initial booted version. The main point is: save the precious files -%$$ you've just created. -%$$ -%$$ Should you choose {\em not to install}, be sure to secure these files -%$$ somewhere/somehow: -%$$ \begin{verbatim} -%$$ ghc/compiler/hsc # compiler -%$$ ghc/runtime/libHSrts_ap.a # RTS things -%$$ ghc/lib/libHS_ap.a # prelude library -%$$ \end{verbatim} -%$$ -%$$ Should you install, the comments about `normal' installing, in -%$$ \Sectionref{GHC_install}, do apply. It should come down to -%$$ something like... -%$$ \begin{verbatim} -%$$ % cd ghc -%$$ % make -n install >& temp-log-file-to-look-at # trial run: chk it out! -%$$ % make install # the real thing... -%$$ \end{verbatim} -%$$ -%$$ (I'd probably do the install by hand, if at all; let me know if you're -%$$ worried about the exact incantations.) -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[testing-init-boot]{Testing the initial boot} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ It wouldn't be a bad idea, especially on an unusual machine; I usually -%$$ just skip this part, though :-) -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsection[split-libs]{Getting ``splitting'' going on your Prelude libraries} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ ghc-split.lprl -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsection[real-version-from-init-boot]{Getting a ``registerised'' version going} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ Version 0.26: THIS DOCUMENTATION IS OUT-OF-DATE. (Sigh) -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[registerised-magic-files]{Setting up files for `registerizing'} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ It's time to jiggle some files related to GCC-magic-optimisation. -%$$ {\em This is real work, folks.} What follows is a {\em rough} guide to -%$$ what needs looking at. -%$$ -%$$ \begin{description} -%$$ %--------------------------------------------------------------------- -%$$ \item[\tr{ghc/includes/MachRegs.lh}:] -%$$ This maps ``STG registers'' (Hp, SpA, TagReg, etc.) to machine -%$$ registers on a platform-by-platform basis. -%$$ If you can't figure it out, you'd probably better ask. -%$$ -%$$ We are using a GCC extension to put C global variables in specific -%$$ registers; see the \tr{Global Reg Vars} node in the GCC documentation. -%$$ -%$$ You should get the idea from the settings for our ``fully supported'' -%$$ platforms, but you will need to know/learn something about your -%$$ hardware and your GCC (e.g., what registers it snaffles for itself). -%$$ -%$$ One way I went about learning these register secrets was to try the -%$$ following test file (a Sun3 version here, \tr{regs3.hc}): -%$$ \begin{verbatim} -%$$ #define StgPtr long int * -%$$ -%$$ register StgPtr FooL0 __asm__("a0"); -%$$ register StgPtr FooL1 __asm__("a1"); -%$$ register StgPtr FooL2 __asm__("a2"); -%$$ register StgPtr FooL3 __asm__("a3"); -%$$ register StgPtr FooL4 __asm__("a4"); -%$$ register StgPtr FooL5 __asm__("a5"); -%$$ register StgPtr FooL6 __asm__("a6"); -%$$ register StgPtr FooL7 __asm__("a7"); -%$$ -%$$ register StgPtr FooG0 __asm__("d0"); -%$$ register StgPtr FooG1 __asm__("d1"); -%$$ register StgPtr FooG2 __asm__("d2"); -%$$ register StgPtr FooG3 __asm__("d3"); -%$$ register StgPtr FooG4 __asm__("d4"); -%$$ register StgPtr FooG5 __asm__("d5"); -%$$ register StgPtr FooG6 __asm__("d6"); -%$$ register StgPtr FooG7 __asm__("d7"); -%$$ -%$$ wurble(x) -%$$ int x; -%$$ { -%$$ return (x + 42); -%$$ } -%$$ \end{verbatim} -%$$ Then compile it repeatedly with your new driver, e.g., -%$$ \tr{ghc-boot-me -v -S regs3.hc}, removing register declarations that -%$$ offend it. Note: GCC's error messages about these register things -%$$ can be less than totally enlightening. -%$$ -%$$ Note: don't worry about warnings that you're stealing a -%$$ ``call-clobbered'' (caller-saves) register. These are stealable, -%$$ though some extra work may be required. -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[\tr{ghc/includes/COptJumps.lh}:] -%$$ The name of the game, essentially, is for the @JMP_@ macro to turn -%$$ into a simple jump instruction. Also, through fiendish collaboration -%$$ with the assembly-language post-processor in the driver (coming up -%$$ soon...), we're going to rip out all the pushing/popping to do with -%$$ the C stack. -%$$ -%$$ You {\em may} need to do something as on 680x0s, where we inject -%$$ beginning-of- and end-of-real-code markers, which gives the post-processor -%$$ something to look out for and tidy up around. -%$$ -%$$ You also need to define some mini-interpreter-related macros. These -%$$ are discussed under \tr{StgMiniInt.lc} (below). -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[\tr{ghc/includes/COptWraps.lh}:] -%$$ -%$$ The macro @STGCALL1(f,a)@ is defined here; it almost certainly should -%$$ just be \tr{callWrapper(f,a)} (where the magical routine @callWrapper@ -%$$ is yet to come). -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[\tr{ghc/driver/ghc-asm-<arch>.lprl}:] -%$$ This is the notorious ``optimised assembler post-processor.'' You -%$$ need to create a suitable \tr{require}-able file (if you haven't -%$$ already), add a mention in the \tr{Jmakefile}, and add suitable code -%$$ in the driver, \tr{ghc.lprl} to invoke it. -%$$ -%$$ This is really quite horrible for a SPARC; we have to shut down the -%$$ register-window mechanism {\em entirely}, by ripping out all the -%$$ \tr{save} and \tr{restore} instructions. -%$$ -%$$ We also go to lots of trouble to move info tables next to entry code, -%$$ elide slow and fast entry-point routines, and probably some things -%$$ I've forgotten about. -%$$ -%$$ Ask if you are desperately confused... -%$$ -%$$ Perhaps it will be less gruesome for your machine! -%$$ -%$$ Don't forget to test it with \tr{-g} turned on (lots of \tr{\.stab?} -%$$ lines suddenly appear)... -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[\tr{CallWrap_C.lc} or \tr{CallWrapper.ls}, in ghc/runtime/c-as-asm/:] -%$$ -%$$ These files have register saving/restoring code. For a SPARC, quite a -%$$ bit has to be written in assembly language (\tr{CallWrapper.ls}), to -%$$ avoid register windowing; but, for other machines, the C versions -%$$ (\tr{CallWrap_C.lc}) should work fine. -%$$ -%$$ Look at the generated assembly-language very carefully! -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[ghc/runtime/c-as-asm/StgMiniInt.lc:] -%$$ -%$$ You need to manage to create entry points named @miniInterpret@ and -%$$ @miniInterpretEnd@, the former to jump off into threaded code; the -%$$ latter to come back to. -%$$ -%$$ You may be able to do something quite simple---it's not bad either for -%$$ mc680x0s or SPARCs---but you will want to inspect the assembler output -%$$ before declaring victory. -%$$ -%$$ In the SPARC case, it uses a macro (@MINI_INTERPRETER_END_IS_HERE@) -%$$ defined in \tr{imports/COptJumps.lh}. -%$$ \end{description} -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[testing-registerisation]{Initial testing of a `registerisation'} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ {\em How to begin testing this registerised stuff:} -%$$ -%$$ Make sure your imports files are up-to-date: -%$$ \begin{verbatim} -%$$ % cd ghc/includes -%$$ % make -%$$ \end{verbatim} -%$$ -%$$ Park yourself in your driver subdirectory and ... -%$$ \begin{verbatim} -%$$ % cd ghc/driver # park -%$$ % make Makefile # if you changed "only4-ghc.ljm"... -%$$ % make # just to be sure -%$$ -%$$ % cp ../compiler/utils/Util.hc temp.hc # grab a test file; -%$$ # you may want to chop it down -%$$ % ghc-boot-me -v -S -ddump-raw-asm temp.hc # see what happens! -%$$ \end{verbatim} -%$$ -%$$ (The \tr{-ddump-raw-asm} option shows you, on stderr, what comes -%$$ directly out of GCC. That's what your post-processing mangler has to -%$$ chomp on.) -%$$ -%$$ {\em Going further on testing this stuff:} -%$$ -%$$ Another good place to practice is \tr{ghc/runtime}; so, for example: -%$$ \begin{verbatim} -%$$ % cd ghc/runtime -%$$ % make Makefile -%$$ % make clean -%$$ % make libHSrts_ap_o.a -%$$ \end{verbatim} -%$$ -%$$ The .s output from \tr{main/StgUpdate.lhc} can be particularly -%$$ enlightening, in that, if you are going to have register spills (e.g., -%$$ because your registerisation choices left GCC with too few with which -%$$ to generate good code), you will see it on this file. -%$$ -%$$ Don't forget: you need a working \tr{CallWrapper.ls} and -%$$ \tr{StgMiniInt.lc} (both in \tr{c-as-asm}) before this registerised -%$$ stuff will actually run. -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[building-registerized]{Building the basics of a registerised GHC} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ \begin{description} -%$$ %--------------------------------------------------------------------- -%$$ \item[What you need to run a registerised program:] -%$$ -%$$ Once you make a \tr{libHSrts_ap_o.a} in runtime, all you need is a -%$$ prelude library. You need to do it by hand still. -%$$ \begin{verbatim} -%$$ % cd ghc/lib -%$$ % ghc-boot-me -c -g -O -osuf _ap_o.o */*.hc # takes a while -%$$ % -%$$ % rm libHS_ap_o.a -%$$ % ar clq libHS_ap_o.a */*_ap_o.o -%$$ % ranlib libHS_ap_o.a -%$$ \end{verbatim} -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Testing the registerised GHC:] -%$$ -%$$ As before, starting with the \tr{.hc} you made in the first round: -%$$ \begin{verbatim} -%$$ % ghc-boot-me -v -g -c test.hc -%$$ % ghc-boot-me -v -g -o test test.o -%$$ % ./test -%$$ \end{verbatim} -%$$ -%$$ If things are broken, the likely outcome is a core dump, and you'll -%$$ need to throw GDB (or equiv) at it. Useful breakpoints are -%$$ \tr{main}, \tr{miniInterpret}, \tr{Main_main_entry}, and -%$$ \tr{startStgWorld} (when you're just getting going), and -%$$ \tr{stopStgWorld} and \tr{miniInterpretEnd} (which can show that you -%$$ ``almost made it''). -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[If you get a consistency-checking error:] -%$$ -%$$ [From the driver] (These are not as terrible as they seem...) -%$$ -%$$ The driver, notably \tr{driver/ghc-consist.lprl}, runs the SCCS -%$$ program \tr{what} over your executable, and tries to make sense of the -%$$ output. -%$$ -%$$ If you need to make changes to \tr{ghc-consist.lprl}, just do so, then -%$$ re-\tr{make} in the driver directory. -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Compiling the compiler registerisedly:] -%$$ -%$$ If you can successfully compile and run {\em some} registerised -%$$ programs, you are probably ready to compile the compiler in that way. -%$$ \begin{verbatim} -%$$ % cd ghc/compiler -%$$ % ghc-boot-me -c -g -O */*.hc # takes *much more* than a while -%$$ % ghc-boot-me -g -O -o hsc */*.o # LINK! -%$$ \end{verbatim} -%$$ -%$$ (Sun3 note: on the particular system I used, I had link troubles. It -%$$ was apparently a Sun bug, because I got a successful link with the GNU -%$$ linker.) -%$$ -%$$ %--------------------------------------------------------------------- -%$$ \item[Testing the {\em whole} registerised GHC:] -%$$ -%$$ As before, but now you can try compiling from \tr{.hs} to \tr{.hc} -%$$ files with the newly-registerised \tr{hsc}. -%$$ \end{description} -%$$ -%$$ %************************************************************************ -%$$ %* * -%$$ \subsubsection[real-version-fine-tuning]{Fine-tuning of a ``registerised'' version of GHC} -%$$ %* * -%$$ %************************************************************************ -%$$ -%$$ NOT FINISHED YET. Let me know if you get this far :-) -%$$ -%$$ installing -%$$ -%************************************************************************ -%* * -\subsection[Compiler_reconfig]{Building GHC again after you've bootstrapped} -\index{GHC reconfiguration, after booting} -\index{booting, then GHC reconfigure} -\index{native-code generator, after booting} -%* * -%************************************************************************ - -Two reasons why you might want to re-configure and re-build GHC after -an initial boot are: (a)~to get a native-code generator, or (b)~if you -are going to hack on GHC. - -The reason you must rebuild to get a native-code generator: The -\tr{.hc} files that we supply do {\em not} include a native-code generator. -(They are supposed to work on and for any machine.) - -From here on, I presume you've installed your booted GHC as -\tr{ghc-2.01}. - -You can configure as before, but using \tr{--with-hc=ghc-2.01} -(\tr{config.status} records what you did before). - -Running \tr{sh < STARTUP} isn't strictly necessary; you only need to -rebuild in \tr{ghc/compiler}: -\begin{verbatim} -cd ghc-2.01/ghc/compiler -make Makefile # if you didn't STARTUP... - -make all EXTRA_HC_OPTS=-fvia-C # -fvia-C important! -make all EXTRA_HC_OPTS=-fvia-C # again, until .hi files settle... -\end{verbatim} - -You might want to to again test GHC ``out of the build'' before you -type \tr{make install} in \tr{ghc/compiler} to finish the job. - -%************************************************************************ -%* * -\section[building-with-HBC]{Building GHC with HBC or other funny Haskell compilers} -\index{GHC, building with HBC} -\index{GHC, building with old GHCs} -\index{GHC, building with other compilers} -%* * -%************************************************************************ - -GHC~2.01 doesn't build with HBC. - -GHC~2.01 can be built with: -\begin{description} -\item[GHC~0.26:] -Provided you don't use \tr{-O} (i.e., configure with -\tr{--disable-hsc-optimised})... - -\item[GHC~0.29:] -Works fine, and builds the fastest compiler; but be sure to configure -with \tr{--with-mkdependHS=blah}, where \tr{blah} is a name to invoke -the \tr{mkdependHS} that comes with GHC~0.29. - -\item[Itself:] -It works, but the resulting compiler is slower. -\end{description} - -%$$ If you are going to build the compiler with HBC, -%$$ please get the appropriate set of \tr{.hi} interface -%$$ files. If you going to build with an old GHC, -%$$ visit your psychiatrist first. -%$$ -%$$ If you choose this route, -%$$ you are well advised to get and install a set of \tr{.hi} interface -%$$ files that were created by the same compiler you intend to use. If -%$$ you intend to use HBC, we may provide a suitable ``spare'' set of \tr{.hi} files, -%$$ in \tr{ghc-0.26-hi-files-hbc.tar.gz}, from an FTP site near you. -%$$ -%$$ Unpack the \tr{.hi} files in this {\em somewhat unobvious} way: -%$$ \begin{verbatim} -%$$ % cd ghc-0.26/ghc/compiler # **** this is where you want to be!!! **** -%$$ -%$$ % gunzip -c ghc-0.26-hi-files-hbc.tar.gz | tar xfv - -%$$ \end{verbatim} - -%************************************************************************ -%* * -\section[Pre-supposed]{Installing pre-supposed utilities} -\index{pre-supposed utilities} -\index{utilities, pre-supposed} -%* * -%************************************************************************ - -Here are the gory details about some utility programs you may need; -\tr{perl} and \tr{gcc} are the only important ones. (PVM is important -if you're going for Parallel Haskell.) The \tr{configure} script will -tell you if you are missing something. - -\begin{description} -\item[Perl:] -\index{pre-supposed: Perl} -\index{Perl, pre-supposed} -{\em You have to have Perl to proceed!} Perl is a language quite good -for doing shell-scripty tasks that involve lots of text processing. -It is pretty easy to install. - -(Perl~5 is the current version; GHC is still friendly to Perl~4 as well.) - -Perl should be put somewhere so that it can be invoked by the \tr{#!} -script-invoking mechanism. (I believe \tr{/usr/bin/perl} is preferred; -we use \tr{/usr/local/bin/perl} at Glasgow.) The full pathname should -be less than 32 characters long. - -\item[GNU C (\tr{gcc}):] -\index{pre-supposed: GCC (GNU C compiler)} -\index{GCC (GNU C compiler), pre-supposed} -The current version is 2.7.2, and has no problems that we know of. - -If your GCC dies with ``internal error'' on some GHC source file, -please let us know, so we can report it and get things improved. -(Exception: on \tr{iX86} boxes---you may need to fiddle with GHC's -\tr{-monly-N-regs} option; ask if confused...) - -\item[PVM version 3:] -\index{pre-supposed: PVM3 (Parallel Virtual Machine)} -\index{PVM3 (Parallel Virtual Machine), pre-supposed} -PVM is the Parallel Virtual Machine on which Parallel Haskell programs -run. Underneath PVM, you can have (for example) a network of -workstations (slow) or a multiprocessor box (faster). - -The current version of PVM is 3.3.11; we use 3.3.7. It is readily available on -the net; I think I got it from \tr{research.att.com}, in \tr{netlib}. - -A PVM installation is slightly quirky, but easy to do. Just follow -the \tr{Readme} instructions. - -\item[\tr{xargs} on Solaris2:] -\index{xargs, presupposed (Solaris only)} -\index{Solaris: alternative xargs} -The GHC libraries are put together with something like: -\begin{verbatim} -find bunch-of-dirs -name '*.o' -print | xargs ar q ... -\end{verbatim} -Unfortunately the Solaris \tr{xargs} (the shell-script equivalent -of \tr{map}) only ``bites off'' the \tr{.o} files a few at a -time---with near-infinite rebuilding of the symbol table in -the \tr{.a} file. - -The best solution is to install a sane \tr{xargs} from the GNU -findutils distribution. You can unpack, build, and install the GNU -version in the time the Solaris \tr{xargs} mangles just one GHC -library. - -\item[\tr{bash} (Parallel Haskell only):] -\index{bash, presupposed (Parallel Haskell only)} -Sadly, the \tr{gr2ps} script, used to convert ``parallelism profiles'' -to PostScript, is written in Bash (GNU's Bourne Again shell). -This bug will be fixed. - -\item[Makeindex:] -\index{pre-supposed: makeindex} -\index{makeindex, pre-supposed} -You won't need this unless you are re-making our documents. Makeindex -normally comes with a \TeX{} distribution, but if not, we can provide -the latest and greatest. - -\item[Tgrind:] -\index{pre-supposed: tgrind} -\index{tgrind, pre-supposed} -This is required only if you remake lots of our documents {\em and} -you use the \tr{-t tgrind} option with \tr{lit2latex} (also literate -programming), to do ``fancy'' typesetting of your code. {\em -Unlikely.} - -\item[Flex:] -\index{pre-supposed: flex} -\index{flex, pre-supposed} -This is a quite-a-bit-better-than-Lex lexer. Used in the -literate-programming stuff. You won't need it unless you're hacking -on some of our more obscure stuff. - -\item[Something other than Sun's \tr{/usr/bin/yacc}:] -\index{pre-supposed: non-worthless Yacc} -\index{Yacc, pre-supposed} -If you mess with the Haskell parser, you'll need a Yacc that can cope. -The unbundled \tr{/usr/lang/yacc} is OK; the GNU \tr{bison} is OK; -Berkeley yacc, \tr{byacc}, is not OK. -\end{description} - -%************************************************************************ -%* * -\section[build-pitfalls]{Known pitfalls in building Glasgow Haskell} -\index{problems, building} -\index{pitfalls, in building} -\index{building pitfalls} -%* * -%************************************************************************ - -WARNINGS about pitfalls and known ``problems'': - -\begin{enumerate} -%------------------------------------------------------------------------ -\item -One difficulty that comes up from time to time is running out of space -in \tr{/tmp}. (It is impossible for the configuration stuff to -compensate for the vagaries of different sysadmin approaches re temp -space.) - -The quickest way around it is \tr{setenv TMPDIR /usr/tmp} or -even \tr{setenv TMPDIR .} (or the equivalent incantation with the -shell of your choice). - -The best way around it is to use the \tr{--with-tmpdir=<dir>} option -to \tr{configure}. Then GHC will use the appropriate directory -in all cases. - -%------------------------------------------------------------------------ -\item -When configuring the support code (mkworld, glafp-utils, etc.), you -will see mention of \tr{NO_SPECIFIC_PROJECT} and -\tr{NO_SPECIFIC_VERSION}. This is cool. - -%------------------------------------------------------------------------ -\item -In compiling some support-code bits, e.g., in \tr{ghc/runtime/gmp} and -even in \tr{ghc/lib}, you may get a few C-compiler warnings. We think -these are OK. - -%------------------------------------------------------------------------ -\item -When compiling via C, you'll sometimes get ``warning: -assignment from incompatible pointer type'' out of GCC. Harmless. - -%------------------------------------------------------------------------ -%\item -%If you build an ``unregisterised'' build, you will get bazillions of -%warnings about `ANSI C forbids braced-groups within expressions'. -%Especially in \tr{ghc/lib}. These are OK. - -%------------------------------------------------------------------------ -\item -Similarly, \tr{ar}chiving warning messages like the following are not -a problem: -\begin{verbatim} -ar: filename GlaIOMonad__1_2s.o truncated to GlaIOMonad_ -ar: filename GlaIOMonad__2_2s.o truncated to GlaIOMonad_ -... -\end{verbatim} - -%------------------------------------------------------------------------ -\item -Also harmless are some specialisation messages that you may see when -compiling GHC; e.g.: -\begin{verbatim} -SPECIALISATION MESSAGES (Desirable): -*** INSTANCES -{-# SPECIALIZE instance Eq [Class] #-} -{-# SPECIALIZE instance Eq (Class, [Class]) #-} -{-# SPECIALIZE instance Outputable [ClassOp] #-} -{-# SPECIALIZE instance Outputable [Id] #-} -\end{verbatim} - -%------------------------------------------------------------------------ -\item -In compiling the compiler proper (in \tr{compiler/}), you {\em may} get an -``Out of heap space'' error message. These -can vary with the vagaries of different systems, it seems. The -solution is simple: (1)~add a suitable \tr{-H} flag to the \tr{compile} -macro for the offending module, -in \tr{ghc/compiler/Jmakefile} (towards the end); -(2)~re-\tr{make Makefile} in that directory; (3)~try again: \tr{make}. - -Alternatively, just cut to the chase scene: -\begin{verbatim} -% cd ghc/compiler -% make EXTRA_HC_OPTS=-H32m # or some nice big number -\end{verbatim} - -%------------------------------------------------------------------------ -\item -Not too long into the build process, you may get a huge complaint -of the form: -\begin{verbatim} -Giant error 'do'ing getopts.pl: at ./lit2pgm.BOOT line 27. -\end{verbatim} -This indicates that your \tr{perl} was mis-installed; the binary is -unable to find the files for its ``built-in'' library. Speak to your -perl installer, then re-try. - -%------------------------------------------------------------------------ -\item -If you try to compile some Haskell, and you get errors from GCC -about lots of things from \tr{/usr/include/math.h}, then your GCC -was mis-installed. \tr{fixincludes} wasn't run when it should've -been. - -As \tr{fixincludes} is now automagically run as part of GCC -installation, this bug also suggests that you have an old GCC. - -%------------------------------------------------------------------------ -%\item -%Sooner or later in your ``make-worlding'' life you will do and see -%something like: -%\begin{verbatim} -%% make Makefile -% rm -f Makefile.bak; mv Makefile Makefile.bak -%../.././mkworld/jmake -P ghc -S std -I../.././mkworld -DTopDir=../../. -DTopDir=... -%../.././mkworld/jrestoredeps -%==== The new Makefile is for: ==== -%make: Fatal error in reader: Makefile, line 850: Unexpected end of line seen -%Current working directory /export/users/fp/grasp/ghc-0.26/ghc/runtimes/standard -%*** Error code 1 -%make: Fatal error: Command failed for target `Makefile' -%\end{verbatim} -% -%Don't panic! It should restore your previous \tr{Makefile}, and -%leave the junk one in \tr{Makefile.bad}. Snoop around at your leisure. - -%------------------------------------------------------------------------ -%\item -%If you do corrupt a \tr{Makefile} totally, or you need to glue a new -%directory into the directory structure (in \tr{newdir}---which must -%have a \tr{Jmakefile}, even if empty), here's a neat trick: -%\begin{verbatim} -%# -%# move to the directory just above the one where you want a Makefile... -%cd .. -%# -%# make Makefiles, but lie about the directories below... -%make Makefiles SUBDIRS=newdir -%\end{verbatim} -% -%This will create a \tr{Makefile} {\em ex nihilo} in \tr{newdir}, and -%it will be properly wired into the general make-world structure. - -%------------------------------------------------------------------------ -%\item -%Don't configure/build/install using a variety of machines. A -%mistake we've made is to do \tr{make Makefiles} on a Sun4, then try to -%build GHC (\tr{make all}) on a Sun3. - -%------------------------------------------------------------------------ -\item -If you end up making documents that involve (La)TeX and/or \tr{tib} -(Simon's favourite), the odds are that something about your/our setup -will reach out and bite you. Yes, please complain; meanwhile, -you can do \tr{make -n whatever.dvi} to see the intended commands, -then try to muddle through, doing them by hand. - -%------------------------------------------------------------------------ -%\item -\end{enumerate} - -%************************************************************************ -%* * -\section[weird-configs]{Making weird GHC configurations} -\index{GHC unusual configurations} -%* * -%************************************************************************ - -The usual way to build a ``weird'' GHC configuration is to turn -various \tr{configure} knobs, e.g., \tr{--enable-concurrent}. -Please see \sectionref{Configuring-GHC} about GHC configuring. - -If you want to build some Very Customised GHC libraries, it's -probably best to send email to us, asking how. - -%$$ Usually, you will build whatever libraries your chosen ``setup'' -%$$ specifies. However, perhaps you are a hacker, and you want an extra -%$$ ``ticky-ticky profiling'' version of the libraries. (Or, you want a -%$$ version compiled with your Very Own Optimisation...) -%$$ -%$$ To create a ``user way'' or setup, put -%$$ something like this somewhere (more on ``somewhere'', below): -%$$ \begin{verbatim} -%$$ #ifndef Build_UserWay_a -%$$ #define Build_UserWay_a YES -%$$ GHC_USER_WAY_FLAG_a = -ticky -%$$ GHC_USER_WAY_OPTS_a = -fstg-reduction-counts -O -%$$ #endif /* ! Build_UserWay_a */ -%$$ \end{verbatim} -%$$ You'll be able to invoke the driver with a \tr{-ticky} option, which -%$$ will be as if you typed in all that other stuff. It will also arrange -%$$ that there is a version of the prelude (\tr{libHS_a.a} library, -%$$ \tr{Prelude_a.hi} to match) and runtime system (\tr{libHSrts_a.a}) to -%$$ match. (Neat, huh?) -%$$ -%$$ On the ``somewhere'' to specify what to build: If you don't plan -%$$ to re-\tr{configure}, just change \tr{site-ghc.jm}. If you do plan to -%$$ re-\tr{configure}, change \tr{site-ghc.jm.in} and re-\tr{configure} -%$$ immediately. -%$$ -%$$ One note about {\em adding} ``user setups'' to an existing build: -%$$ Besides remaking your \tr{Makefiles} straight away, {\em don't forget} -%$$ to remake the driver (in \tr{ghc/driver}) before making any libraries! -%$$ The short cut is: -%$$ \begin{verbatim} -%$$ cd ..../ghc/driver -%$$ make Makefile; make all -%$$ cd ../runtime -%$$ make Makefile; make all -%$$ cd ../lib -%$$ make Makefile; make all -%$$ \end{verbatim} - -\upsection - -%************************************************************************ -%* * -\section[building-Haggis]{Building Haggis (Haskell GUI toolkit)} -\index{Haggis, building} -\index{building Haggis} -%* * -%************************************************************************ - -NOT DONE YET. - -%************************************************************************ -%* * -\section[building-Happy]{Building Happy (Haskell parser generator)} -\index{Happy, building} -\index{building Happy} -%* * -%************************************************************************ - -NOT DONE YET. - -%************************************************************************ -%* * -\section[building-NoFib]{Building NoFib (Haskell benchmark suite)} -\index{NoFib suite, building} -\index{building the NoFib suite} -%* * -%************************************************************************ - -NOT DONE YET. - -%************************************************************************ -%* * -\section[Configuring]{Running \tr{configure}} -\index{configure script} -%* * -%************************************************************************ - -The GNU-style \tr{configure} script figures out things which we need -to know to build one or more Glasgow tools for your machine. Also, -\tr{configure} lets you specify what you want built. - -Most people will configure/build one tool at a time. The -``short-cut'' instructions -for GHC are in \sectionref{Configuring-GHC}, -for Haggis in \sectionref{Configuring-Haggis}, -for Happy in \sectionref{Configuring-Happy}, -and for NoFib in \sectionref{Configuring-NoFib}. - -However, \tr{configure} lets you pick and choose, so you can build -several things ``in a one-er''. Just fling in all the options -at once, and be amazed. - -%************************************************************************ -%* * -\subsection[Configuring-general]{\tr{configure} options for all tools} -\index{Configuring (general)} -%* * -%************************************************************************ - -Many \tr{configure} options apply no matter what tools you are building. - -\begin{description} -\item[\tr{--help}:] (a standard GNU option) -\index{--help configure option} -Prints out a long usage message. The first part is GNU boilerplate; -after that is the Glasgow info. - -\item[\tr{--prefix=}{\em directory}:] (a standard GNU option) -\index{--prefix configure option} -Sets the ``root'' directory for where a system should be installed; -defaults to \tr{/usr/local}. - -With Happy, for example, the main \tr{happy} binary will end up in -\tr{/usr/local/bin/happy}. - -%-------------------------------------------------------------- -\item[\tr{--exec-prefix=}{\em directory}:] (a standard GNU option) -\index{--exec-prefix configure option} -Sets the ``root'' directory -for where executables -(e.g., the GHC driver) should be installed; defaults to whatever -\tr{--prefix} is, -meaning that things will be installed in \tr{/usr/local/bin}. - -%$$ At Glasgow, we want such executables to go in (e.g.) -%$$ \tr{/local/fp/bin.sun4}, so \tr{--exec-prefix} is no use to us. -%$$ Happily, there's more than one way to do it!---just change -%$$ \tr{InstBinDir_GHC} in \tr{ghc/mkworld/site-ghc.jm.in}... (We hope -%$$ this doesn't bring back too many bad memories for our -%$$ pre-\tr{configure} users.) - -%-------------------------------------------------------------- -\item[\tr{--with-hc=}{\em hask}:] -\index{--with-hc configure option} -Use {\em hask} as my ``installed Haskell compiler.'' - -The name {\em hask} has to be one of \tr{ghc*} (for Glasgow Haskell), -\tr{hbc*} (for Chalmers HBC), or \tr{nhc*} (for Rojemo's NHC). -We hope to add more! - -As a special case, \tr{--with-hc=c} means ``I don't have a Haskell -compiler, please compile from intermediate C files (produced by GHC -somewhere else).'' - -%-------------------------------------------------------------- -\item[\tr{--with-mkdependHS=}{\em mkdep}:] -\index{--with-mkdependHS configure option} - -Use {\em mkdep} as your \tr{mkdependHS} program. You should use the -\tr{mkdependHS} that came with the GHC which you are probably -specifying via \tr{--with-hc=...}. - -%-------------------------------------------------------------- -\item[\tr{--with-gcc=}{\em blah}:] -\index{--with-gcc configure option} -Use {\em blah} as my ``GNU C compiler.'' In case you have several, -and want to chose a particular one. - -%-------------------------------------------------------------- -\item[\tr{--with-make=}{\em blub}:] -\index{--with-make configure option} -Ditto, for ``make''. - -%-------------------------------------------------------------- -\item[\tr{--with-tmpdir=}{\em directory}:] -Set the directory where temporary files should be created. This is -\tr{/tmp} by default, which is Sometimes Uncool (because, e.g., -\tr{/tmp} is too small). There's just no telling. - -On our Alphas, for example, we use \tr{--with-tmpdir=/usr/tmp}. - -%-------------------------------------------------------------- -\item[\tr{--with-max-heap=}{\em size}:] -When whatever Haskell compiler is run while building the Glasgow -tools, it will try to use some sane-but-not-too-big heap size. If you -have a machine with plenty of memory, you might want to say ``Go ahead -and use a great big heap.'' This option allows this. So, for -example, on our Alphas we might say \tr{--with-max-heap=48m}. -\end{description} - -%************************************************************************ -%* * -\subsection[Configuring-GHC]{GHC-specific things in \tr{configure}} -\index{Configuring for GHC} -%* * -%************************************************************************ - -The easiest way to see all the \tr{configure} options for GHC is to -type \tr{./configure --help}. (I don't feel like typing the whole -thing again, into this document...) - -Some common combinations would be: - -\begin{verbatim} -./configure --prefix=/users/fp/partain --with-hc=c --disable-profiling - # use .hc files; don't bother with profiling - -./configure --with-hc=ghc-0.29 --with-readline-library --with-sockets-library - # simple build with 0.29 - # For the extra libraries, you've got to have the right - # stuff to link to. - -./configure --with-hc=ghc-0.29 --disable-hsc-optimised --enable-hsc-debug - # Don't use -O on GHC itself; turn on -DDEBUG. - # Slows things down, but it's The Right Thing if - # you're hacking on GHC and doing lots of recompilations. - -./configure --with-hc=c --enable-concurrent --enable-parallel --with-tmpdir=/usr/tmp - # Do everything from .hc files; besides the normal ones, - # you'll need the "prof", "conc" and "par" .hc files. - # Use /usr/tmp as TMPDIR... -\end{verbatim} - -Remember, if you build \tr{--with-hc=c} on a Sun4 or Alpha, you -do {\em not} have a native-code generator. - -%************************************************************************ -%* * -\subsection[Configuring-HsLibs]{Haskell-libraries-specific things in \tr{configure}} -\index{Configuring the Haskell libraries} -%* * -%************************************************************************ - -The normal thing is: \tr{--enable-hslibs --with-hc-for-hslibs=in-place}. - -NOT DONE YET. - -%************************************************************************ -%* * -\subsection[Configuring-Haggis]{Haggis-specific things in \tr{configure}} -\index{Configuring for Haggis} -%* * -%************************************************************************ - -Use \tr{--enable-haggis}. If you have Haggis and GHC in the same -build tree but only want to build Haggis, use \tr{--disable-ghc}. - -MORE TO COME. - -%************************************************************************ -%* * -\subsection[Configuring-Happy]{Happy-specific things in \tr{configure}} -\index{Configuring for Happy} -%* * -%************************************************************************ - -Use \tr{--enable-happy}. If you have Happy and GHC in the same -build tree but only want to build Happy, use \tr{--disable-ghc}. - -MORE TO COME. - -%************************************************************************ -%* * -\subsection[Configuring-NoFib]{NoFib-specific things in \tr{configure}} -\index{Configuring for NoFib} -%* * -%************************************************************************ - -Use \tr{--enable-nofib --with-setup=ghc}. -If you have NoFib and GHC in the same build -tree but only want to build the NoFib suite, use \tr{--disable-ghc}. - -(If you were testing HBC on NoFib, you'd do \tr{--with-setup=hbc}, of course.) - -You may want to enable or disable various sets of tests, as -suggested by \tr{./configure --help}. If you use \tr{--enable-all-tests}, -be aware that many of them are GHC-specific. Also, we may not have -given you all of the source :-) - -%************************************************************************ -%* * -\section[STARTUP]{Running \tr{STARTUP}} -\index{STARTUP script} -%* * -%************************************************************************ - -Once you've \tr{configure}d, utter the magic incantation: -\begin{verbatim} -% sh < STARTUP >& startup.log -\end{verbatim} -The reason you might want to pipe the chatter into a file is so you -can check it afterwards. It should be pretty obvious if it is happy. -Note: it takes a little while. - -\tr{STARTUP} is a simple shell script that builds \tr{mkworld} -(Makefile-generating system), \tr{literate} (literate-programming -system), and \tr{glafp-utils} (a few utility programs); then makes the -Makefiles and dependencies for everything. - -If you have any problems before getting through \tr{STARTUP}, you -are probably best off re-running \tr{configure} and \tr{STARTUP} -(after fixing what was broken). - -%************************************************************************ -%* * -\section[utils_install]{Installing the support software (optional)} -\index{utilities, installing} -%* * -%************************************************************************ - -By default, the support software that comes with the Glasgow -tools---\tr{mkworld}, \tr{literate}, and \tr{glafp-utils}---is not -installed. However, they're generally-useful tools, so... - -If you did want to install the ``make world'' system, for example: -\begin{verbatim} -% cd <very-top>/mkworld -% make install -\end{verbatim} - -If it isn't installing things where you want it to, you can either -fiddle things on the fly... -\begin{verbatim} -% make install prefix=/home/sweet/home -\end{verbatim} - -If you want to install just one utility, for example \tr{lndir}: -\begin{verbatim} -% cd <very-top>/glafp-utils/scripts -% make install_lndir -\end{verbatim} - -``Make world''---It slices, it dices... it's great! - -%************************************************************************ -%* * -\section[arrangement-of-sources]{Arrangement of the sources} -%* * -%************************************************************************ - -Once you un\tr{tar} the Glorious Haskell Compilation (GHC) system sources -and \tr{cd} into the top directory, here's a bird's-eye view of what -you should see: - -\begin{tabular}{ll} -mkworld/ & ``Make world'' sub-system for configuring the system.\\ - & \\ -glafp-utils/ & Utility programs and scripts used in building the distribution;\\ - & often acquired from elsewhere. \\ -literate/ & Glasgow literate programming sub-system. \\ - & \\ -ghc/driver/ & The driver program for GHC; \\ - & currently a perl script, \tr{ghc}. \\ - & \\ -ghc/compiler/ & The Haskell compiler proper, called \tr{hsc}; \\ - & source files are in \tr{compiler/*/[A-Z]*.lhs}. \\ - & \\ -ghc/runtime/ & The runtime system, including the garbage-collector(s).\\ - & \\ -ghc/lib/ & Source for the linked-in code for the ``standard prelude''. \\ -ghc/includes/ & The .h files \tr{#include}d in generated .hc files.\\ - & \\ -ghc/docs/ & documents; see the README file there. \\ - & \\ -ghc/CONTRIB/ & reserved for contributed things \\ - & \\ -hslibs/ghc/ & `ghc' system library (syslib) \\ -hslibs/hbc/ & `hbc' system library \\ -hslibs/posix/ & `posix' system library \\ -hslibs/contrib/ & `contrib' system library \\ - & \\ -haggis/ & Haggis Haskell X11 GUI toolkit \\ -happy/ & Happy Haskell parser generator \\ -nofib/ & NoFib Haskell benchmark and test suite \\ -\end{tabular} - -\begin{onlystandalone} -\printindex -\end{document} -\end{onlystandalone} diff --git a/ghc/docs/release_notes/Makefile b/ghc/docs/release_notes/Makefile deleted file mode 100644 index 49d154e4a2..0000000000 --- a/ghc/docs/release_notes/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -TOP = ../../.. -LiterateSuffixRules = YES -include $(TOP)/ghc/mk/ghc.mk - -#DocProcessingSuffixRules() -#LitDocRootTarget(release,lit) diff --git a/ghc/docs/state_interface/Makefile b/ghc/docs/state_interface/Makefile deleted file mode 100644 index c1ab89541e..0000000000 --- a/ghc/docs/state_interface/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -TOP = ../../.. -include $(TOP)/ghc/mk/ghc.mk - -state-interface.dvi : state-interface.tex - $(LATEX) state-interface.tex - -state-interface.tex : state-interface.verb - @$(RM) state-interface.tex - expand state-interface.verb | verbatim > state-interface.tex diff --git a/ghc/docs/state_interface/state-interface.verb b/ghc/docs/state_interface/state-interface.verb deleted file mode 100644 index 51ae81b43f..0000000000 --- a/ghc/docs/state_interface/state-interface.verb +++ /dev/null @@ -1,1156 +0,0 @@ -\documentstyle[a4wide,grasp]{article} -\renewcommand{\textfraction}{0.1} -\renewcommand{\floatpagefraction}{0.9} -\renewcommand{\dblfloatpagefraction}{0.9} - -\sloppy -\renewcommand{\today}{July 1996} - -\begin{document} - -\title{The GHC Prelude and Libraries} -\author{Simon L Peyton Jones \and Will Partain} - -\maketitle -\tableofcontents - -\section{Introduction} - -This document describes GHC's prelude and libraries. The basic story is that of -the Haskell 1.3 Report and Libraries document (which we do not reproduce here), -but this document describes in addition: -\begin{itemize} -\item GHC's additional non-standard libraries and types, such as state transformers, - packed strings, foreign objects, stable pointers, and so on. - -\item GHC's primitive types and operations. The standard Haskell functions are implemented - on top of these, and it is sometimes useful to use them directly. - -\item The organsiation of these libraries into directories. -\end{itemize} - -\section{Overview} - -The libraries are organised into the following three groups, each of which -is kept in a separate sub-directory of GHC's installed @lib/@ directory: -\begin{description} -\item[@lib/required/@] These are the libraries {\em required} by the Haskell -definition. All are defined by the Haskell Report, or by the Haskell Libraries Report. -They currently comprise: -\begin{itemize} -\item @Prelude@. -\item @List@: more functions on lists. -\item @Char@: more functions on characters. -\item @Maybe@: more functions on @Maybe@ types. -\item @Complex@: functions on complex numbers. -\item @Ratio@: functions on rational numbers. -\item @Monad@: functions on characters. -\item @Ix@: the @Ix@ class of indexing operations. -\item @Array@: monolithic arrays. -\item @IO@: basic input/output functions. -\item @Directory@: basic functions for accessing the file system. -\item @System@: basic operating-system interface functions. -\end{itemize} - -\item[@lib/glaExts@] GHC extension libraries, currently comprising: -\begin{itemize} -\item @PackedString@: functions that manipulate strings packed efficiently, one character per byte. -\item @ST@: the state transformer monad. -\item @Foreign@: types and operations for GHC's foreign-language interface. -\end{itemize} - -\item[@lib/concurrent@] GHC extension libraries to support Concurrent Haskell, currently comprising: -\begin{itemize} -\item @Concurrent.hs@: main library. -\item @Parallel.hs@: stuff for multi-processor parallelism. -\item @Channel.hs@ -\item @ChannelVar.hs@ -\item @Merge.hs@ -\item @SampleVar.hs@ -\item @Semaphore.hs@ -\end{itemize} - -\item[@lib/ghc@] These libraries are the pieces on which all the others are built. -They aren't typically imported by Joe Programmer, but there's nothing to stop you -doing so if you want. In general, the modules prefixed by @Prel@ are pieces that go -towards building @Prelude@. - -\begin{itemize} -\item @GHC@: this ``library'' brings into scope all the primitive types and operations, such as -@Int#@, @+#@, @encodeFloat#@, etc etc. It is unique in that there is no Haskell -source code for it. Details in Section \ref{sect:ghc}. - -\item @PrelBase@: defines the basic types and classes without which very few Haskell programs can work. -The classes are: @Eq@, @Ord@, @Enum@, @Bounded@, @Num@, @Show@, @Eval@, @Monad@, @MonadZero@, @MonadPlus@. -The types are: list, @Bool@, @Char@, @Ordering@, @String@, @Int@, @Integer@, @Maybe@, @Either@. - -\item @PrelTup@: defines tuples and their instances. -\item @PrelList@: defines most of the list operations required by @Prelude@. (A few are in @PrelBase@, -to avoid gratuitous mutual recursion between modules.) - -\item @PrelNum@ defines: the numeric classes beyond @Num@ (namely @Real@, @Integral@, -@Fractional@, @Floating@, @RealFrac@, @RealFloat@; instances for appropriate classes -for @Int@ and @Integer@; the types @Float@, @Double@, and @Ratio@ and their instances. - -\item @PrelRead@: the @Read@ class and all its instances. It's kept separate because many programs -don't use @Read@ at all, so we don't even want to link in its code. - -\item @ConcBase@: substrate stuff for Concurrent Haskell. - -\item @IOBase@: substrate stuff for the main I/O libraries. -\item @IOHandle@: large blob of code for doing I/O on handles. -\item @PrelIO@: the remaining small pieces to produce the I/O stuff needed by @Prelude@. - -\item @STBase@: substrate stuff for @ST@. -\item @ArrBase@: substrate stuff for @Array@. - -\item @GHCerr@: error reporting code, called from code that the compiler plants in compiled programs. -\item @GHCmain@: the definition of @mainPrimIO@, which is what {\em really} gets - called by the runtime system. @mainPrimIO@ in turn calls @main@. -\end{itemize} -\end{description} - -The @...Base@ modules generally export representation information that -is hidden from the public interface. For example the module @STBase@ -exports the type @ST@ including its representation, whereas the module -@ST@ exports @ST@ abstractly. - -None of these modules are involved in any mutual recursion, with the sole exception that -many modules import @IOBase.error@. - -\section{The module @GHC@: really primitive stuff} -\label{sect:ghc} - -This section defines all the types which are primitive in Glasgow Haskell, and the -operations provided for them. - -A primitive type is one which cannot be defined in Haskell, and which -is therefore built into the language and compiler. Primitive types -are always unboxed; that is, a value of primitive type cannot be -bottom. - -Primitive values are often represented by a simple bit-pattern, such as @Int#@, -@Float#@, @Double#@. But this is not necessarily the case: a primitive value -might be represented by a pointer to a heap-allocated object. Examples include -@Array#@, the type of primitive arrays. You might think this odd: doesn't being -heap-allocated mean that it has a box? No, it does not. A primitive array is -heap-allocated because it is too big a value to fit in a register, and would be -too expensive to copy around; in a sense, it is accidental that it is represented -by a pointer. If a pointer represents a primitive value, then it really does -point to that value: no unevaluated thunks, no indirections...nothing can be at -the other end of the pointer than the primitive value. - -This section also describes a few non-primitive types, which are needed -to express the result types of some primitive operations. - -\subsection{Character and numeric types} - -There are the following obvious primitive types: -@ -type Char# -type Int# -- see also Word# and Addr#, later -type Float# -type Double# -@ -If you want to know their exact equivalents in C, see -@ghc/includes/StgTypes.lh@ in the GHC source. - -Literals for these types may be written as follows: -@ -1# an Int# -1.2# a Float# -1.34## a Double# -'a'# a Char#; for weird characters, use '\o<octal>'# -"a"# an Addr# (a `char *') -@ - -\subsubsection{Comparison operations} -@ -{gt,ge,eq,ne,lt,le}Char# :: Char# -> Char# -> Bool - -- ditto for Int#, Word#, Float#, Double#, and Addr# -@ - -\subsubsection{Unboxed-character operations} -@ -ord# :: Char# -> Int# -chr# :: Int# -> Char# -@ - -\subsubsection{Unboxed-@Int@ operations} -@ -{plus,minus,times,quot,div,rem}Int# :: Int# -> Int# -> Int# -negateInt# :: Int# -> Int# -@ -NB: No error/overflow checking! - -\subsubsection{Unboxed-@Double@ and @Float@ operations} -@ -{plus,minus,times,divide}Double# :: Double# -> Double# -> Double# -negateDouble# :: Double# -> Double# - -float2Int# :: Double# -> Int# -- just a cast, no checking! -int2Double# :: Int# -> Double# - -expDouble# :: Double# -> Double# -logDouble# :: Double# -> Double# -sqrtDouble# :: Double# -> Double# -sinDouble# :: Double# -> Double# -cosDouble# :: Double# -> Double# -tanDouble# :: Double# -> Double# -asinDouble# :: Double# -> Double# -acosDouble# :: Double# -> Double# -atanDouble# :: Double# -> Double# -sinhDouble# :: Double# -> Double# -coshDouble# :: Double# -> Double# -tanhDouble# :: Double# -> Double# -powerDouble# :: Double# -> Double# -> Double# -@ -There's an exactly-matching set of unboxed-@Float@ ops; replace -@Double#@ with @Float#@ in the list above. There are two -coercion functions for @Float#@/@Double#@: -@ -float2Double# :: Float# -> Double# -double2Float# :: Double# -> Float# -@ -The primitive versions of @encodeDouble@/@decodeDouble@: -@ -encodeDouble# :: Int# -> Int# -> ByteArray# -- Integer mantissa - -> Int# -- Int exponent - -> Double# - -decodeDouble# :: Double# - -> GHCbase.ReturnIntAndGMP -@ -(And the same for @Float#@s.) - -\subsection{Operations on/for @Integers@ (interface to GMP)} -\label{sect:horrid-Integer-pairing-types} - -We implement @Integers@ (arbitrary-precision integers) using the GNU -multiple-precision (GMP) package. - -NB: some of this might change if we upgrade to using GMP~2.x. - -The data type for @Integer@ must mirror that for @MP_INT@ in @gmp.h@ -(see @gmp.info@). It comes out as: -@ -data Integer = J# Int# Int# ByteArray# -@ -So, @Integer@ is really just a ``pairing'' type for a particular -collection of primitive types. - -The operations in the GMP return other combinations of -GMP-plus-something, so we need ``pairing'' types for those, too: -@ -data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray# -data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray# - --- ????? something to return a string of bytes (in the heap?) -@ -The primitive ops to support @Integers@ use the ``pieces'' of the -representation, and are as follows: -@ -negateInteger# :: Int# -> Int# -> ByteArray# -> Integer - -{plus,minus,times}Integer# :: Int# -> Int# -> ByteArray# - -> Int# -> Int# -> ByteArray# - -> Integer - -cmpInteger# :: Int# -> Int# -> ByteArray# - -> Int# -> Int# -> ByteArray# - -> Int# -- -1 for <; 0 for ==; +1 for > - -divModInteger#, quotRemInteger# - :: Int# -> Int# -> ByteArray# - -> Int# -> Int# -> ByteArray# - -> GHCbase.Return2GMPs - -integer2Int# :: Int# -> Int# -> ByteArray# - -> Int# - -int2Integer# :: Int# -> Integer -- NB: no error-checking on these two! -word2Integer# :: Word# -> Integer - -addr2Integer# :: Addr# -> Integer - -- the Addr# is taken to be a `char *' string - -- to be converted into an Integer -@ - - -\subsection{Words and addresses} - -A @Word#@ is used for bit-twiddling operations. It is the same size as -an @Int#@, but has no sign nor any arithmetic operations. -@ -type Word# -- Same size/etc as Int# but *unsigned* -type Addr# -- A pointer from outside the "Haskell world" (from C, probably); - -- described under "arrays" -@ -@Word#@s and @Addr#@s have the usual comparison operations. -Other unboxed-@Word@ ops (bit-twiddling and coercions): -@ -and#, or# :: Word# -> Word# -> Word# - -not# :: Word# -> Word# - -shiftL#, shiftRA#, shiftRL# :: Word# -> Int# -> Word# - -- shift left, right arithmetic, right logical - -iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int# - -- same shift ops, but on Int#s - -int2Word# :: Int# -> Word# -- just a cast, really -word2Int# :: Word# -> Int# -@ - -Unboxed-@Addr@ ops (C casts, really): -@ -int2Addr# :: Int# -> Addr# -addr2Int# :: Addr# -> Int# -@ -Operations for indexing off of C pointers (@Addr#@s) to snatch values -are listed under ``arrays''. - -\subsection{Arrays} - -The type @Array# elt@ is the type of primitive, -unboxed arrays of values of type @elt@. -@ -type Array# elt -@ -@Array#@ is more primitive than a Haskell -array --- indeed, Haskell arrays are implemented using @Array#@ --- -in that an @Array#@ is indexed only by @Int#@s, starting at zero. It is also -more primitive by virtue of being unboxed. That doesn't mean that it isn't -a heap-allocated object --- of course, it is. Rather, being unboxed means -that it is represented by a pointer to the array itself, and not to a thunk -which will evaluate to the array (or to bottom). -The components of an @Array#@ are themselves boxed. - -The type @ByteArray#@ is similar to @Array#@, except that it contains -just a string of (non-pointer) bytes. -@ -type ByteArray# -@ -Arrays of these types are useful when a Haskell program wishes to -construct a value to pass to a C procedure. It is also possible to -use them to build (say) arrays of unboxed characters for internal use -in a Haskell program. Given these uses, @ByteArray#@ is deliberately -a bit vague about the type of its components. Operations are provided -to extract values of type @Char#@, @Int#@, @Float#@, @Double#@, and -@Addr#@ from arbitrary offsets within a @ByteArray#@. (For type @Foo#@, -the $i$th offset gets you the $i$th @Foo#@, not the @Foo#@ at byte-position $i$. Mumble.) -(If you want a @Word#@, grab an @Int#@, then coerce it.) - -Lastly, we have static byte-arrays, of type @Addr#@ [mentioned -previously]. (Remember the duality between arrays and pointers in C.) -Arrays of this types are represented by a pointer to an array in the -world outside Haskell, so this pointer is not followed by the garbage -collector. In other respects they are just like @ByteArray#@. They -are only needed in order to pass values from C to Haskell. - -\subsubsection{Reading and writing.} - -Primitive arrays are linear, and indexed starting at zero. - -The size and indices of a @ByteArray#@, @Addr#@, and -@MutableByteArray#@ are all in bytes. It's up to the program to -calculate the correct byte offset from the start of the array. This -allows a @ByteArray#@ to contain a mixture of values of different -type, which is often needed when preparing data for and unpicking -results from C. (Umm... not true of indices... WDP 95/09) - -{\em Should we provide some @sizeOfDouble#@ constants?} - -Out-of-range errors on indexing should be caught by the code which -uses the primitive operation; the primitive operations themselves do -{\em not} check for out-of-range indexes. The intention is that the -primitive ops compile to one machine instruction or thereabouts. - -We use the terms ``reading'' and ``writing'' to refer to accessing {\em mutable} -arrays (see Section~\ref{sect:mutable}), and ``indexing'' -to refer to reading a value from an {\em immutable} -array. - -If you want to read/write a @Word#@, read an @Int#@ and coerce. - -Immutable byte arrays are straightforward to index (all indices in bytes): -@ -indexCharArray# :: ByteArray# -> Int# -> Char# -indexIntArray# :: ByteArray# -> Int# -> Int# -indexAddrArray# :: ByteArray# -> Int# -> Addr# -indexFloatArray# :: ByteArray# -> Int# -> Float# -indexDoubleArray# :: ByteArray# -> Int# -> Double# - -indexCharOffAddr# :: Addr# -> Int# -> Char# -indexIntOffAddr# :: Addr# -> Int# -> Int# -indexFloatOffAddr# :: Addr# -> Int# -> Float# -indexDoubleOffAddr# :: Addr# -> Int# -> Double# -indexAddrOffAddr# :: Addr# -> Int# -> Addr# -- Get an Addr# from an Addr# offset -@ -The last of these, @indexAddrOffAddr#@, extracts an @Addr#@ using an offset -from another @Addr#@, thereby providing the ability to follow a chain of -C pointers. - -Something a bit more interesting goes on when indexing arrays of boxed -objects, because the result is simply the boxed object. So presumably -it should be entered --- we never usually return an unevaluated -object! This is a pain: primitive ops aren't supposed to do -complicated things like enter objects. The current solution is to -return a lifted value, but I don't like it! -@ -indexArray# :: Array# elt -> Int# -> GHCbase.Lift elt -- Yuk! -@ - -\subsubsection{The state type} - -The primitive type @State#@ represents the state of a state transformer. -It is parameterised on the desired type of state, which serves to keep -states from distinct threads distinct from one another. But the {\em only} -effect of this parameterisation is in the type system: all values of type -@State#@ are represented in the same way. Indeed, they are all -represented by nothing at all! The code generator ``knows'' to generate no -code, and allocate no registers etc, for primitive states. -@ -type State# s -@ - -The type @GHCbuiltins.RealWorld@ is truly opaque: there are no values defined -of this type, and no operations over it. It is ``primitive'' in that -sense---but it is {\em not unboxed!} Its only role in life is to be the type -which distinguishes the @PrimIO@ state transformer (see -Section~\ref{sect:io-spec}). -@ -data RealWorld -@ - -\subsubsection{States} - -A single, primitive, value of type @State# RealWorld@ is provided. -@ -realWorld# :: State# GHCbuiltins.RealWorld -@ -(Note: in the compiler, not a @PrimOp@; just a mucho magic @Id@.) - -\subsection{State pairing types} -\label{sect:horrid-pairing-types} - -This subsection defines some types which, while they aren't quite primitive -because we can define them in Haskell, are very nearly so. They define -constructors which pair a primitive state with a value of each primitive type. -They are required to express the result type of the primitive operations in the -state monad. -@ -data StateAndPtr# s elt = StateAndPtr# (State# s) elt - -data StateAndChar# s = StateAndChar# (State# s) Char# -data StateAndInt# s = StateAndInt# (State# s) Int# -data StateAndWord# s = StateAndWord# (State# s) Word# -data StateAndFloat# s = StateAndFloat# (State# s) Float# -data StateAndDouble# s = StateAndDouble# (State# s) Double# -data StateAndAddr# s = StateAndAddr# (State# s) Addr# - -data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a) -data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj# -data StateAndSynchVar# s a = StateAndSynchVar# (State# s) (SynchVar# a) - -data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt) -data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt) -data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray# -data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s) -@ - - -\subsection{Mutable arrays} -\label{sect:mutable} - -Corresponding to @Array#@ and @ByteArray#@, -we have the types of mutable versions of each. -In each case, the representation is a pointer -to a suitable block of (mutable) heap-allocated storage. -@ -type MutableArray# s elt -type MutableByteArray# s -@ -\subsubsection{Allocation.} - -Mutable arrays can be allocated. -Only pointer-arrays are initialised; arrays of non-pointers are filled -in by ``user code'' rather than by the array-allocation primitive. -Reason: only the pointer case has to worry about GC striking with a -partly-initialised array. -@ -newArray# :: Int# -> elt -> State# s -> StateAndMutableArray# s elt - -newCharArray# :: Int# -> State# s -> StateAndMutableByteArray# s -newIntArray# :: Int# -> State# s -> StateAndMutableByteArray# s -newAddrArray# :: Int# -> State# s -> StateAndMutableByteArray# s -newFloatArray# :: Int# -> State# s -> StateAndMutableByteArray# s -newDoubleArray# :: Int# -> State# s -> StateAndMutableByteArray# s -@ -The size of a @ByteArray#@ is given in bytes. - -\subsubsection{Reading and writing} - -%OLD: Remember, offsets in a @MutableByteArray#@ are in bytes. -@ -readArray# :: MutableArray# s elt -> Int# -> State# s -> StateAndPtr# s elt -readCharArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndChar# s -readIntArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndInt# s -readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndAddr# s -readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndFloat# s -readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndDouble# s - -writeArray# :: MutableArray# s elt -> Int# -> elt -> State# s -> State# s -writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s -writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s -writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s -writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s -@ - -\subsubsection{Equality.} - -One can take ``equality'' of mutable arrays. What is compared is the -{\em name} or reference to the mutable array, not its contents. -@ -sameMutableArray# :: MutableArray# s elt -> MutableArray# s elt -> Bool -sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool -@ - -\subsubsection{Freezing mutable arrays} - -Only unsafe-freeze has a primitive. (Safe freeze is done directly in Haskell -by copying the array and then using @unsafeFreeze@.) -@ -unsafeFreezeArray# :: MutableArray# s elt -> State# s -> StateAndArray# s elt -unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> StateAndByteArray# s -@ - -\subsubsection{Stable pointers} - -{\em Andy's comment.} {\bf Errors:} The following is not strictly true: the current -implementation is not as polymorphic as claimed. The reason for this -is that the C programmer will have to use a different entry-routine -for each type of stable pointer. At present, we only supply a very -limited number (1) of these routines. It might be possible to -increase the range of these routines by providing general purpose -entry points to apply stable pointers to (stable pointers to) -arguments and to enter (stable pointers to) boxed primitive values. -{\em End of Andy's comment.} - -A stable pointer is a name for a Haskell object which can be passed to the -external world. It is ``stable'' in the sense that the name does not change when -the Haskell garbage collector runs --- in contrast to the address of the object -which may well change. - -The stable pointer type is parameterised by the type of the thing which is named. -@ -type StablePtr# a -@ -A stable pointer is represented by an index into the (static) -@StablePointerTable@. The Haskell garbage collector treats the -@StablePointerTable@ as a source of roots for GC. - -The @makeStablePointer@ function converts a value into a stable pointer. -It is part of the @PrimIO@ monad, because we want to be sure we don't -allocate one twice by accident, and then only free one of the copies. -@ -makeStablePointer# :: a -> State# RealWorld -> StateAndStablePtr# RealWorld a -freeStablePointer# :: StablePtr# a -> State# RealWorld -> State# RealWorld -deRefStablePointer# :: StablePtr# a -> State# RealWorld -> StateAndPtr RealWorld a -@ -There is also a C procedure @FreeStablePtr@ which frees a stable pointer. - -% -% Rewritten and updated for MallocPtr++ -- 4/96 SOF -% -\subsubsection{Foreign objects} - -A @ForeignObj@ is a reference to an object outside the Haskell -world (i.e., from the C world, or a reference to an object on another -machine completely.), where the Haskell world has been told ``Let me -know when you're finished with this ...''. - -The @ForeignObj@ type is just a special @Addr#@ ({\em not} parameterised). -@ -type ForeignObj# -@ - -A typical use of @ForeignObj@ is in constructing Haskell bindings -to external libraries. A good example is that of writing a binding to -an image-processing library (which was actually the main motivation -for implementing @ForeignObj@'s precursor, @MallocPtr@). The -images manipulated are not stored in the Haskell heap, either because -the library insist on allocating them internally or we (sensibly) -decide to spare the GC from having to heave heavy images around. - -@ -data Image = Image ForeignObj# - -instance CCallable Image -@ - -The @ForeignObj#@ type is then used to refer to the externally -allocated image, and to acheive some type safety, the Haskell binding -defines the @Image@ data type. So, a value of type @ForeignObj#@ is -used to ``box'' up an external reference into a Haskell heap object -that we can then indirectly reference: - -@ -createImage :: (Int,Int) -> PrimIO Image -@ - -So far, this looks just like an @Addr#@ type, but @ForeignObj#@ -offers a bit more, namely that we can specify a {\em finalisation -routine} to invoke when the @ForeignObj#@ is discarded by the -GC. The garbage collector invokes the finalisation routine associated -with the @ForeignObj#@, saying `` Thanks, I'm through with this -now..'' For the image-processing library, the finalisation routine could for -the images free up memory allocated for them. The finalisation routine has -currently to be written in C (the finalisation routine can in turn call on -@FreeStablePtr@ to deallocate a stable pointer.). - -Associating a finalisation routine with an external object is done by -@makeForeignObj#@: - -@ -makeForeignObj# :: Addr# -- foreign reference - -> Addr# -- pointer to finalisation routine - -> StateAndForeignObj# RealWorld ForeignObj# -@ - -(Implementation: a linked list of all @ForeignObj#@s is maintained to allow the - garbage collector to detect when a @ForeignObj#@ becomes garbage.) - -Like @Array@, @ForeignObj#@s are represented by heap objects. - -{\bf ToDo:} Decide whether @FreeCHeapPointer@ is allowed to call on a -stable pointer. (I sincerely hope not since we will still be in the -GC at this point.) - -\subsubsection{Synchronizing variables (I-vars, M-vars)} - -ToDo ToDo ToDo - -@ -type SynchVar# s elt -- primitive - -newSynchVar#:: State# s -> StateAndSynchVar# s elt - -takeMVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt -putMVar# :: SynchVar# s elt -> State# s -> State# s - -readIVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt -writeIVar# :: SynchVar# s elt -> State# s -> State# s -@ - -\subsubsection{Controlling the garbage collector} - -The C function {\tt PerformGC\/}, allows the C world to force Haskell -to do a garbage collection. It can only be called while Haskell -is performing a C Call. - -Note that this function can be used to define a Haskell IO operation -with the same effect: -@ -> performGCIO :: PrimIO () -> performGCIO = _ccall_gc_ PerformGC -@ - -{\bf ToDo:} Is there any need for abnormal/normal termination to force -a GC too? Is there any need for a function that provides finer -control over GC: argument = amount of space required; result = amount -of space recovered. - -\subsection{@spark#@ primitive operation (for parallel execution)} - -{\em ToDo: say something} It's used in the unfolding for @par@. - -\subsection{The @errorIO#@ primitive operation} - -The @errorIO#@ primitive takes an argument much like @PrimIO@. It aborts execution of -the current program, and continues instead by performing the given @PrimIO@-like value -on the current state of the world. -@ -errorIO# :: (State RealWorld -> ((), State RealWorld)) -> a -@ - -\subsection{C Calls} - -{\bf ToDo:} current implementation has state variable as second -argument not last argument. - -The @ccall#@ primitive can't be given an ordinary type, because it has -a variable number of arguments. The nearest we can get is: -@ -ccall# :: CRoutine -> a1# -> ... -> an# -> State# RealWorld -> StateAndR# RealWorld -@ -where the type variables @a1#@\ldots@an#@ and @r#@ can be instantiated by any -primitive type, and @StateAndR#@ is the appropriate pairing type from -Section~\ref{sect:horrid-pairing-types}. The @CRoutine@ -isn't a proper Haskell type at all; it just reminds us that @ccall#@ needs to -know what C routine to call. - -This notation is really short for a massive family of @ccall#@ primitives, one -for each combination of types. (Of course, the compiler simply remembers the -types involved, and generates appropriate code when it finally spits out the C.) - -Unlike all the other primitive operators, @ccall#@ is not bound to an in-scope -identifier. The only way it is possible to generate a @ccall#@ is via the -@_ccall_@ construct. - -All this applies equally to @casm#@: -@ -casm# :: CAsmString -> a1# -> ... -> an# -> State# RealWorld -> StateAndR# RealWorld -@ - -%------------------------------------------------------------ -\section{Library stuff built with the Really Primitive Stuff} - -\subsection{The state transformer monad} - -\subsubsection{Types} - -A state transformer is a function from a state to a pair of a result and a new -state. -@ -newtype ST s a = ST (State s -> (a, State s)) -@ -The @ST@ type is {\em abstract}, so that the programmer cannot see its -representation. If he could, he could write bad things like: -@ -bad :: ST s a -bad = ST $ \ s -> ...(f s)...(g s)... -@ -Here, @s@ is duplicated, which would be bad news. - -A state is represented by a primitive state value, of type @State# s@, -wrapped up in a @State@ constructor. The reason for boxing it in this -way is so that we can be strict or lazy in the state. (Remember, all -primitive types are unboxed, and hence can't be bottom; but types built -with @data@ are all boxed.) -@ -data State s = S# (State# s) -@ - -\subsubsection{The state transformer combinators} - -Now for the combinators, all of which live inside the @ST@ -abstraction. Notice that @returnST@ and @thenST@ are lazy in the -state. -@ -returnST :: a -> ST s a -returnST a s = (a, s) - -thenST :: ST s a -> (a -> ST s b) -> ST s b -thenST m k s = let (r,new_s) = m s - in - k r new_s - -fixST :: (a -> ST s a) -> ST s a -fixST k s = let ans = k r s - (r,new_s) = ans - in - ans -@ -The interesting one is, of course, @runST@. We can't infer its type! -(It has a funny name because it must be wired into the compiler.) -@ --- runST :: forall a. (forall s. ST s a) -> a -runST m = case m (S# realWorld#) of - (r,_) -> r -@ - -\subsubsection{Other useful combinators} - -There are various other standard combinators, all defined in terms the -fundamental combinators above. The @seqST@ combinator is like -@thenST@, except that it discards the result of the first state -transformer: -@ -seqST :: ST s a -> ST s b -> ST s b -seqST m1 m2 = m1 `thenST` (\_ -> m2) -@ - -We also have {\em strict} (... in the state...) variants of the -then/return combinators (same types as their pals): -@ -returnStrictlyST a s@(S# _) = (a, s) - -thenStrictlyST m k s@(S# _) - = case (m s) of { (r, new_s@(S# _)) -> - k r new_s } - -seqStrictlyST m k = ... ditto, for seqST ... -@ - -The combinator @listST@ takes a list of state transformers, and -composes them in sequence, returning a list of their results: -@ -listST :: [ST s a] -> ST s [a] -listST [] = returnST [] -listST (m:ms) = m `thenST` \ r -> - listST ms `thenST` \ rs -> - returnST (r:rs) -@ -The @mapST@ combinator ``lifts'' a function from a value to state -transformers to one which works over a list of values: -@ -mapST :: (a -> ST s b) -> [a] -> ST s [b] -mapST f ms = listST (map f ms) -@ -The @mapAndUnzipST@ combinator is similar to @mapST@, except that here the -function returns a pair: -@ -mapAndUnzipST :: (a -> ST s (b,c)) -> [a] -> ST s ([b],[c]) -mapAndUnzipST f (m:ms) - = f m `thenST` \ ( r1, r2) -> - mapAndUnzipST f ms `thenST` \ (rs1, rs2) -> - returnST (r1:rs1, r2:rs2) -@ - -\subsubsection{The @PrimIO@ monad} -\label{sect:io-spec} - -The @PrimIO@ type is defined in as a state transformer which manipulates the -@RealWorld@. -@ -type PrimIO a = ST RealWorld a -- Transparent -@ -The @PrimIO@ type is an ordinary type synonym, transparent to the programmer. - -The type @RealWorld@ and value @realWorld#@ do not need to be hidden (although -there is no particular point in exposing them). Even having a value of type -@realWorld#@ does not compromise safety, since the type @ST@ is hidden. - -It is type-correct to use @returnST@ in an I/O context, but it is a -bit more efficient to use @returnPrimIO@. The latter is strict in the -state, which propagates backwards to all the earlier combinators -(provided they are unfolded). Why is it safe for @returnPrimIO@ to be -strict in the state? Because every context in which an I/O state -transformer is used will certainly evaluate the resulting state; it is -the state of the real world! -@ -returnPrimIO :: a -> PrimIO a -returnPrimIO a s@(S# _) -> (a, s) -@ -We provide strict versions of the other combinators too. -@ -thenPrimIO m k s = case m s of - (r,s) -> k r s -@ -@fixPrimIO@ has to be lazy, though! -@ -fixPrimIO = fixST -@ -The other combinators are just the same as before, but use the strict -@thenPrimIO@ and @returnPrimIO@ for efficiency. -@ -foldrPrimIO f z [] = z -foldrPrimIO f z (m:ms) = foldrPrimIO f z ms `thenPrimIO` \ ms' -> - f m ms' - -listPrimIO ms = foldrPrimIO (\ a xs -> a `thenPrimIO` \ x -> returnPrimIO (x : xs)) - (returnPrimIO []) ms - -mapPrimIO f ms = listPrimIO (map f ms) - -mapAndUnzipPrimIO f (m:ms) - = f m `thenPrimIO` \ ( r1, r2) -> - mapAndUnzipPrimIO f ms `thenPrimIO` \ (rs1, rs2) -> - returnPrimIO (r1:rs1, r2:rs2) -@ - -\subsection{Arrays} - -\subsubsection{Types} - -@ -data Array ix elt = Array (ix,ix) (Array# elt) -data ByteArray ix = ByteArray (ix,ix) ByteArray# - -data MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt) -data MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s) -@ - -\subsubsection{Operations on immutable arrays} - -Ordinary array indexing is straightforward. -@ -(!) :: Ix ix => Array ix elt -> ix -> elt -@ -QUESTIONs: should @ByteArray@s be indexed by Ints or ix? With byte offsets -or sized ones? (sized ones [WDP]) -@ -indexCharArray :: Ix ix => ByteArray ix -> ix -> Char -indexIntArray :: Ix ix => ByteArray ix -> ix -> Int -indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr -indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float -indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double -@ -@Addr@s are indexed straightforwardly by @Int@s. Unlike the primitive -operations, though, the offsets assume that the array consists entirely of the -type of value being indexed, and so there's an implicit multiplication by -the size of that value. To access @Addr@s with mixed values requires -you to do a DIY job using the primitives. -@ -indexAddrChar :: Addr -> Int -> Char -...etc... -indexStaticCharArray :: Addr -> Int -> Char -indexStaticIntArray :: Addr -> Int -> Int -indexStaticFloatArray :: Addr -> Int -> Float -indexStaticDoubleArray :: Addr -> Int -> Double -indexStaticArray :: Addr -> Int -> Addr -@ - -\subsubsection{Operations on mutable arrays} -@ -newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) -newCharArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) -... -@ - -@ -readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt -readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char -... -@ - -@ -writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () -writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () -... -@ - -@ -freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -... -@ - -We have no need on one-function-per-type for unsafe freezing: -@ -unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -@ - -Sometimes we want to snaffle the bounds of one of these beasts: -@ -boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix) -boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix) -@ - -Lastly, ``equality'': -@ -sameMutableArray :: MutableArray s ix elt -> MutableArray s ix elt -> Bool -sameMutableByteArray :: MutableByteArray s ix -> MutableByteArray s ix -> Bool -@ - - -\subsection{Variables} - -\subsubsection{Types} - -Mutable variables are (for now anyway) implemented as arrays. The @MutableVar@ type -is opaque, so we can change the implementation later if we want. -@ -type MutableVar s a = MutableArray s Int a -@ - -\subsubsection{Operations} -@ -newVar :: a -> ST s (MutableVar s a) -readVar :: MutableVar s a -> ST s a -writeVar :: MutableVar s a -> a -> ST s () -sameVar :: MutableVar s a -> MutableVar s a -> Bool -@ - -\subsection{Stable pointers} - -Nothing exciting here, just simple boxing up. -@ -data StablePtr a = StablePtr (StablePtr# a) - -makeStablePointer :: a -> StablePtr a -freeStablePointer :: StablePtr a -> PrimIO () -@ - -\subsection{Foreign objects} - -Again, just boxing up. -@ -data ForeignObj = ForeignObj ForeignObj# - -makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj -@ - -\subsection{C calls} - -Everything in this section goes for @_casm_@ too. - -{\em ToDo: mention @_ccall_gc_@ and @_casm_gc_@...} - -The @_ccall_@ construct has the following form: -$$@_ccall_@~croutine~a_1~\ldots~a_n$$ -This whole construct has type $@PrimIO@~res$. -The rules are these: -\begin{itemize} -\item -The first ``argument'', $croutine$, must be the literal name of a C procedure. -It cannot be a Haskell expression which evaluates to a string, etc; it must be -simply the name of the procedure. -\item -The arguments $a_1, \ldots,a_n$ must be of {\em C-callable} type. -\item -The whole construct has type $@PrimIO@~ty$, where $ty$ is a {\em C-returnable} type. -\end{itemize} -A {\em boxed-primitive} type is both C-callable and C-returnable. -A boxed primitive type is anything declared by: -@ -data T = C# t -@ -where @t@ is a primitive type. Note that -programmer-defined boxed-primitive types are perfectly OK: -@ -data Widget = W# Int# -data Screen = S# CHeapPtr# -@ - -There are other types that can be passed to C (C-callable). This -table summarises (including the standard boxed-primitive types): -@ -Boxed Type of transferd Corresp. Which is -Type Prim. component C type *probably*... ------- --------------- ------ ------------- -Char Char# StgChar unsigned char -Int Int# StgInt long int -Word Word# StgWord unsigned long int -Addr Addr# StgAddr char * -Float Float# StgFloat float -Double Double# StgDouble double - -Array Array# StgArray StgPtr -ByteArray ByteArray# StgByteArray StgPtr -MutableArray MutableArray# StgArray StgPtr -MutableByteArray MutableByteArray# StgByteArray StgPtr - -State State# nothing! - -StablePtr StablePtr# StgStablePtr StgPtr -ForeignObj ForeignObj# StgForeignObj StgPtr -@ - -All of the above are {\em C-returnable} except: -@ - Array, ByteArray, MutableArray, MutableByteArray -@ - -{\bf ToDo:} I'm pretty wary of @Array@ and @MutableArray@ being in -this list, and not too happy about @State@ [WDP]. - -{\bf ToDo:} Can code generator pass all the primitive types? Should this be -extended to include {\tt Bool\/} (or any enumeration type?) - -The type checker must be able to figure out just which of the C-callable/returnable -types is being used. If it can't, you have to add type signatures. For example, -@ -f x = _ccall_ foo x -@ -is not good enough, because the compiler can't work out what type @x@ is, nor -what type the @_ccall_@ returns. You have to write, say: -@ -f :: Int -> PrimIO Float -f x = _ccall_ foo x -@ - -\subsubsection{Implementation} - -The desugarer unwraps the @_ccall_@ construct by inserting the necessary -evaluations etc to unbox the arguments. For example, the body of the definition -of @f@ above would become: -@ - (\ s -> case x of { I# x# -> - case s of { S# s# -> - case ccall# [Int#,Float#] x# s# of { StateAndFloat# f# new_s# -> - (F# f#, S# new_s#) - }}}) -@ -Notice that the state, too, is unboxed. - -The code generator must deal specially with primitive objects which -are stored on the heap. - -... details omitted ... - -% -%More importantly, it must construct a C Heap Pointer heap-object after -%a @_ccall_@ which returns a @MallocPtr#@. -% - -%-------------------------------------------------------- -\section{Non-primitive stuff that must be wired into GHC} - -@ -data Char = C# Char# -data Int = I# Int# -data Word = W# Word# -data Addr = A# Addr# - -data Float = F# Float# -data Double = D# Double# -data Integer = J# Int# Int# ByteArray# - --- and the other boxed-primitive types: - Array, ByteArray, MutableArray, MutableByteArray, - StablePtr, ForeignObj - -data Bool = False | True -data Ordering = LT | EQ | GT -- used in derived comparisons - -data List a = [] | a : (List a) --- tuples... - -data Lift a = Lift a -- used Yukkily as described elsewhere - -type String = [Char] -- convenience, only -@ - -%------------------------------------------------------------ -\section{Programmer interface(s)} - -\subsection{The bog-standard interface} - -If you rely on the implicit @import Prelude@ that GHC normally does -for you, and if you don't use any weird flags (notably -@-fglasgow-exts@), and if you don't import one of the fairly-magic -@PreludeGla*@ interfaces, then GHC should work {\em exactly} as the -Haskell report says, and the full user namespaces should be available -to you. - -\subsection{If you mess about with @import Prelude@...} - -Innocent hiding, e.g., -@ -import Prelude hiding ( fromIntegral ) -@ -should work just fine. - -There are some things you can do that will make GHC crash, e.g., -hiding a standard class: -@ -import Prelude hiding ( Eq(..) ) -@ -Don't do that. - -\subsection{Turning on Glasgow extensions with @-fglasgow-exts@} - -If you turn on @-fglasgow-exts@, then all the primitive types and -operations described herein are available. - -It is possible that some name conflicts between your code and the -wired-in things might spring to life (though we doubt it...). -Change your names :-) - -\end{document} - diff --git a/ghc/docs/release_notes/2-01-notes.lit b/ghc/docs/users_guide/2-01-notes.lit index 5ac4d4cf80..5ac4d4cf80 100644 --- a/ghc/docs/release_notes/2-01-notes.lit +++ b/ghc/docs/users_guide/2-01-notes.lit diff --git a/ghc/docs/users_guide/2-02-notes.lit b/ghc/docs/users_guide/2-02-notes.lit new file mode 100644 index 0000000000..7ee4631f91 --- /dev/null +++ b/ghc/docs/users_guide/2-02-notes.lit @@ -0,0 +1,112 @@ +Release~2.02 is the first release of Glasgow Haskell for Haskell~1.4. + +The announcement for this release is distributed as \tr{ANNOUNCE-2.02} +in the top-level directory. It contains very important caveats about +2.02, which we do not repeat here! + +Information about ``what's ported to which machine'' is in the +Installation Guide. Since 2.01, we've added support for Windows NT. + +%************************************************************************ +%* * +\subsection[2-02-config]{New configuration things in 2.01} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[2-02-user-visible]{User-visible changes in 2.01, including incompatibilities} +%* * +%************************************************************************ + +GHC~2.01 is a compiler for Haskell~1.4 and, as such, introduces many +user-visible changes. The GHC user's guide has a section to help you +upgrade your programs to Haskell~1.4; all user-visible changes +are described there (and not repeated here). + +%************************************************************************ +%* * +\subsection[2-02-options]{New or changed GHC command-line options} +%* * +%************************************************************************ + +\begin{itemize} +\item GHC now warns of possibly-incomplete patterns in case expressions +and function bindings. You can suppress these warnings with @-fno-warn-incomplete-patterns@. + +GHC also warns of completely overlapped patterns. You can't switch this off. + +\item GHC can warn of shadowed names, though it does not do so by default. +Just occasionally this shows up +an otherwise hard-to-find bug. To warn of shadowed names use @-fwarn-name-shadowing@ + +\item For hackers, the flag @-dshow-rn-trace@ shows what the renamer is up to. +\end{itemize} + + +%************************************************************************ +%* * +\subsection[2-02-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +\begin{itemize} +\item +Completely new ``make-world'' system, properly documented (at last) in the +installation guide. No Jmakefiles; but you need Gnu make (gmake). + +\item +The ``renamer''---the part of the compiler that implements +the Haskell module system---has been completely rewritten, again. + +The format of interface files has changed significantly. Interface files +generated by 2.01 will not work with 2.02. + +\item +Even less special pleading for the Prelude than in 2.01. If you wanted +to write your own Prelude and drop it in, you would have +a really good chance now. +\end{itemize} + + +%************************************************************************ +%* * +\subsection[2-02-new-in-libraries]{In the libraries} +%* * +%************************************************************************ + +The libraries have been completely reorganised. There's a description in +... + + +%************************************************************************ +%* * +\subsection[2-02-new-in-syslibs]{In ``hslibs'' libraries} +%* * +%************************************************************************ + + +%************************************************************************ +%* * +\subsection[2-02-new-in-rts]{In the runtime system} +%* * +%************************************************************************ + +\begin{itemize} +\item @ForeignObjs@ are properly deallocated when execution halts, as well +as when the @ForeignObj@ becomes unreferenced. +This is important if you are using a @ForeignObj@ to refer to +a @COM@ object or other remote resource. You want that resource to be relased +when the program terminates. + +\item Files handles are handled using @ForeignObjs@, and closed when the file handle +is unreferenced. This means that if you +open zillions of files then just letting go of the file handle is enough +to close it. +\end{itemize} + +%************************************************************************ +%* * +%\subsection[2-02-new-elsewhere]{Other new stuff} +%* * +%************************************************************************ diff --git a/ghc/docs/users_guide/Makefile b/ghc/docs/users_guide/Makefile index 005ab541b8..7c67def91f 100644 --- a/ghc/docs/users_guide/Makefile +++ b/ghc/docs/users_guide/Makefile @@ -1,7 +1,6 @@ -TOP = ../../.. -LiterateSuffixRules = YES -include $(TOP)/ghc/mk/ghc.mk +TOP = ../.. +include $(TOP)/mk/boilerplate.mk -#DocProcessingSuffixRules() -#LitDocRootTarget(profiling,lit) -#LitDocRootTarget(user,lit) +DOC_SRCS = profiling.lit user.lit + +include $(TOP)/mk/target.mk diff --git a/ghc/docs/users_guide/how_to_run.lit b/ghc/docs/users_guide/how_to_run.lit index 7c8ee0c02b..a67833f6f5 100644 --- a/ghc/docs/users_guide/how_to_run.lit +++ b/ghc/docs/users_guide/how_to_run.lit @@ -5,18 +5,17 @@ Command-line arguments are either options or file names. Command-line options begin with \tr{-}. They may {\em not} be -grouped: \tr{-vO} is different from \tr{-v -O}. -Options need not precede filenames: e.g., \tr{ghc *.o -o foo}. -All options are processed -and then apply to all files; you cannot, for example, -invoke \tr{ghc -c -O1 Foo.hs -O2 Bar.hs} to apply different -optimisation levels to the files \tr{Foo.hs} and \tr{Bar.hs}. For -conflicting options, e.g., \tr{-c -S}, we reserve the right to do -anything we want. (Usually, the last one applies.) +grouped: \tr{-vO} is different from \tr{-v -O}. Options need not +precede filenames: e.g., \tr{ghc *.o -o foo}. All options are +processed and then applied to all files; you cannot, for example, invoke +\tr{ghc -c -O1 Foo.hs -O2 Bar.hs} to apply different optimisation +levels to the files \tr{Foo.hs} and \tr{Bar.hs}. For conflicting +options, e.g., \tr{-c -S}, we reserve the right to do anything we +want. (Usually, the last one applies.) Options related to profiling, Glasgow extensions to Haskell (e.g., -unboxed values), Concurrent and Parallel Haskell are -described in \sectionref{profiling}, \sectionref{glasgow-exts}, and +unboxed values), Concurrent and Parallel Haskell are described in +\sectionref{profiling}, \sectionref{glasgow-exts}, and \sectionref{concurrent-and-parallel}, respectively. %************************************************************************ @@ -85,6 +84,10 @@ Please, oh please, use the \tr{-v} option when reporting bugs! Knowing that you ran the right bits in the right order is always the first thing we want to verify. +If you're just interested in the compiler version number, the +\tr{--version}\index{--version option} option prints out a +one-line string containing the requested info. + %************************************************************************ %* * \subsection[options-order]{Running the right phases in the right order} @@ -126,7 +129,8 @@ native-code generator is used (producing assembly language) or not %files as if they had suffix \pl{<suf>}. [NOT IMPLEMENTED YET] The option \tr{-cpp}\index{-cpp option} must be given for the C -pre-processor phase to be run. +pre-processor phase to be run, that is, the pre-processor will be run +over your Haskell source file before continuing. The option \tr{-E}\index{-E option} runs just the C-preprocessor part of the C-compiling phase, sending the result to stdout [I think]. (For @@ -156,8 +160,9 @@ following ``packages'' of optimisations (or lack thereof) should suffice. Once you choose a \tr{-O*} ``package,'' stick with it---don't chop and change. Modules' interfaces {\em will} change with a shift to a new -\tr{-O*} option, and you will have to recompile all importing modules -before your program can again be run safely. +\tr{-O*} option, and you may have to recompile a large chunk of all +importing modules before your program can again be run +safely\sectionref{recomp}. \begin{description} \item[No \tr{-O*}-type option specified:] @@ -392,7 +397,7 @@ then `2'. If `2' doesn't work, please report the bug to us. \index{GCC optimisation} The C~compiler (GCC) is run with \tr{-O} turned on. (It has -to be, actually.) +to be, actually). If you want to run GCC with \tr{-O2}---which may be worth a few percent in execution speed---you can give a @@ -404,7 +409,7 @@ percent in execution speed---you can give a %************************************************************************ %* * -\subsection[options-sanity]{Sanity-checking options} +\subsection[options-sanity]{Warnings and sanity-checking} \index{sanity-checking options} %* * %************************************************************************ @@ -415,14 +420,31 @@ option.\index{-fsignatures-required option} If you would like to disallow ``name shadowing,'' i.e., an inner-scope value has the same name as an outer-scope value, then use the -\tr{-fname-shadowing-not-ok} -option.\index{-fname-shadowing-not-ok option} +\tr{-fwarn-name-shadowing} +option.\index{-fwarn-name-shadowing option} This option catches typographical errors that turn into hard-to-find bugs, e.g., in the inadvertent cyclic definition \tr{let x = ... x ... in}. Consequently, this option does {\em not} allow cyclic recursive definitions. +By default, the compiler will warn you if a set of patterns are either +incomplete (i.e., you're only matching on a subset of an algebraic +data type's constructors), or overlapping, i.e., + +\begin{verbatim} +f :: String -> Int +f [] = 0 +f (_:xs) = 1 +f "2" = 2 +\end{verbatim} + +where the last pattern match won't ever be reached, as the second +pattern overlaps it. More often than not, `completeness' of +patterns is a programmer mistake/error, but if you don't want +the compiler to ``baby-sit'', use \tr{-fno-warn-incomplete-patterns} option +to turn them off.\index{-fno-warn-incomplete-patterns option}. + If you're feeling really paranoid, the \tr{-dcore-lint} option\index{-dcore-lint option} is a good choice. It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's @@ -467,8 +489,8 @@ Note: this ``feature'' can be counterintuitive: \tr{ghc -C -o foo.o foo.hs} will put the intermediate C code in the file \tr{foo.o}, name notwithstanding! -EXOTICA: But the \tr{-o} option isn't much use if you have {\em -several} input files... Non-interface output files are normally put +EXOTICA: But the \tr{-o} option isn't of much use if you have {\em +several} input files... Non-interface output files are normally put in the same directory as their corresponding input file came from. You may specify that they be put in another directory using the \tr{-odir <dir>}\index{-odir <dir> option} (the ``Oh, dear'' option). @@ -538,8 +560,9 @@ variable.\index{TMPDIR environment variable} Set it to the name of the directory where temporary files should be put. GCC and other programs will honour the \tr{TMPDIR} variable as well. -EVEN BETTER IDEA: Configure GHC with \tr{--with-tmpdir=<mumble>} when -you build it, and never worry about \tr{TMPDIR} again. +EVEN BETTER IDEA: Set the \tr{TMPDIR} variable when building +GHC, and never worry about \tr{TMPDIR} again. (see the build +documentation). %************************************************************************ %* * @@ -629,7 +652,7 @@ The \tr{ghc} driver pre-defines several macros: \index{__HASKELL1__ macro} If defined to $n$, that means GHC supports the Haskell language defined in the Haskell report version $1.n$. -Currently 3. +Currently 4. NB: This macro is set both when pre-processing Haskell source and when pre-processing generated C (\tr{.hc}) files. @@ -654,9 +677,8 @@ implementations that support C-style pre-processing. \item[\tr{__CONCURRENT_HASKELL__}:] \index{__CONCURRENT_HASKELL__ macro} Only defined when \tr{-concurrent} is in use! -This symbol is -defined when pre-processing Haskell (input) and pre-processing C (GHC -output). +This symbol is defined when pre-processing Haskell (input) and +pre-processing C (GHC output). \item[\tr{__PARALLEL_HASKELL__}:] \index{__PARALLEL_HASKELL__ macro} @@ -696,7 +718,7 @@ THIS MAY CHANGE. Meanwhile, options so sent are: \index{-dgcc-lint option (GCC paranoia)} If you are compiling with lots of \tr{ccalls}, etc., you may need to -tell the C~compiler about some \tr{#include} files. There is no +tell the C~compiler about some \tr{#include} files. There is no real pretty way to do this, but you can use this hack from the command-line: \begin{verbatim} @@ -1173,6 +1195,38 @@ Main.skip2{-r1L6-} = trademark of Peyton Jones Enterprises, plc.) %---------------------------------------------------------------------- +\subsubsection[source-file-options]{Command line options in source files} +\index{source-file options} + +Sometimes it is useful to make the connection between a source file +and the command-line options it requires, quite tight. For instance, +if a (Glasgow) Haskell source file uses \tr{casm}s, the C back-end +often needs to be told about header files to use, +\ref{-#include <file> option}. Rather than maintaining the list of +files the source depends on in a \tr{Makefile}, it is possible to +do this directly in the source file using the \tr{OPTIONS} pragma +\index{OPTIONS pragma}: + +\begin{verbatim} +{-# OPTIONS -#include "foo.h" #-} +module X where + +... +\end{verbatim} + +\tr{OPTIONS} pragmas are only looked for at the top of your source +files, upto the first (non-literate,non-empty) line not containing +\tr{OPTIONS}. Multiple \tr{OPTIONS} pragmas are recognised. Note +that your command shell does not get to the source file options, they +are just included literally in the array of command-line arguments +the compiler driver maintains internally, so you'll be desperately +disappointed if you try to glob etc. inside \tr{OPTIONS}. + +It is not recommended to move all the contents of your Makefiles into +your source files, but in some circumstances, the \tr{OPTIONS} pragma +is the Right Thing. + +%---------------------------------------------------------------------- %\subsubsection[arity-checking]{Options to insert arity-checking code} %\index{arity checking} % diff --git a/ghc/docs/users_guide/intro.lit b/ghc/docs/users_guide/intro.lit index 82b6e93f95..48926d2f97 100644 --- a/ghc/docs/users_guide/intro.lit +++ b/ghc/docs/users_guide/intro.lit @@ -1,10 +1,10 @@ % -% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/users_guide/Attic/intro.lit,v 1.2 1996/07/25 20:48:26 partain Exp $ +% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/users_guide/Attic/intro.lit,v 1.3 1997/03/14 07:59:31 simonpj Exp $ % \section[introduction-GHC]{Introduction to GHC} This is a guide to using the Glasgow Haskell compilation (GHC) system. -It is a batch compiler for the Haskell~1.3 language, with support for +It is a batch compiler for the Haskell~1.4 language, with support for various Glasgow-only extensions. Many people will use GHC very simply: compile some @@ -30,11 +30,11 @@ material in \sectionref{compiler-tutorial} may help. On the World-Wide Web, there are several URLs of likely interest: \begin{display} -GHC home page -- http://www.dcs.gla.ac.uk/fp/software/ghc/ -Glasgow FP group page -- http://www.dcs.gla.ac.uk/fp/ -comp.lang.functional FAQ -- http://www.cs.nott.ac.uk/Department/Staff/mpj/faq.html +GHC home page -- \tr{http://www.dcs.gla.ac.uk/fp/software/ghc/} +Glasgow FP group page -- \tr{http://www.dcs.gla.ac.uk/fp/} +comp.lang.functional FAQ -- \tr{http://www.cs.nott.ac.uk/Department/Staff/mpj/faq.html} programming language research page -- - http://www.cs.cmu.edu/afs/cs.cmu.edu/user/mleone/web/language-research.html + \tr{http://www.cs.cmu.edu/afs/cs.cmu.edu/user/mleone/web/language-research.html} \end{display} We run two mailing lists about Glasgow Haskell. We encourage you to join, as you feel is appropriate. @@ -54,7 +54,7 @@ To contact the list administrator, send mail to \tr{glasgow-haskell-users-request}. An archive of the list is available on the Web at: \begin{verbatim} -\tr{http://www.dcs.gla.ac.uk/mail-www/glasgow-haskell-users}. +\url{http://www.dcs.gla.ac.uk/mail-www/glasgow-haskell-users} \end{verbatim} \item[glasgow-haskell-bugs:] @@ -72,7 +72,7 @@ Again, you may contact the list administrator at And, yes, an archive of the list is available on the Web at: \begin{verbatim} -\tr{http://www.dcs.gla.ac.uk/mail-www/glasgow-haskell-bugs}. +\url{http://www.dcs.gla.ac.uk/mail-www/glasgow-haskell-bugs} \end{verbatim} \end{description} diff --git a/ghc/docs/users_guide/libraries.lit b/ghc/docs/users_guide/libraries.lit index 891d9b1d5e..55d4c06180 100644 --- a/ghc/docs/users_guide/libraries.lit +++ b/ghc/docs/users_guide/libraries.lit @@ -1,1075 +1,1156 @@ -%************************************************************************ -%* * -\section[syslibs]{System libraries} -\index{system libraries} -\index{libraries, system} -%* * -%************************************************************************ - -We intend to provide more and more ready-to-use Haskell code, so that -every program doesn't have to invent everything from scratch. - -If you provide a \tr{-syslib <name>}\index{-syslib <name> option} option, -then the interfaces for that library will come into scope (and may be -\tr{import}ed), and the code will be added in at link time. - -We supply a part of the HBC library (\tr{-syslib hbc}); as well as one -of our own (\tr{-syslib ghc}); one for an interface to POSIX routines -(\tr{-syslib posix}); and one of contributed stuff off the net, mostly -numerical (\tr{-syslib contrib}). - -If you have Haggis (our GUI X~toolkit for Haskell), it probably works -with a \tr{-syslib haggis} flag. - -%************************************************************************ -%* * -\subsection[GHC-library]{The GHC system library} -\index{library, GHC} -\index{GHC library} -%* * -%************************************************************************ - -We have started to put together a ``GHC system library.'' - -At the moment, the library is made of generally-useful bits of the -compiler itself. - -To use this library, just give a \tr{-syslib ghc}\index{-syslib ghc option} -option to GHC, both for compiling and linking. - -%************************************************************************ -%* * -\subsubsection[Bag]{The @Bag@ type} -\index{Bag module (GHC syslib)} -%* * -%************************************************************************ - -A {\em bag} is an unordered collection of elements which may contain -duplicates. To use, \tr{import Bag}. - -\begin{verbatim} -emptyBag :: Bag elt -unitBag :: elt -> Bag elt - -unionBags :: Bag elt -> Bag elt -> Bag elt -unionManyBags :: [Bag elt] -> Bag elt -consBag :: elt -> Bag elt -> Bag elt -snocBag :: Bag elt -> elt -> Bag elt - -concatBag :: Bag (Bag a) -> Bag a -mapBag :: (a -> b) -> Bag a -> Bag b - -foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative - -> (a -> r) -- Replace UnitBag with this - -> r -- Replace EmptyBag with this - -> Bag a - -> r - -elemBag :: Eq elt => elt -> Bag elt -> Bool -isEmptyBag :: Bag elt -> Bool -filterBag :: (elt -> Bool) -> Bag elt -> Bag elt -partitionBag :: (elt -> Bool) -> Bag elt-> (Bag elt, Bag elt) - -- returns the elements that do/don't satisfy the predicate - -listToBag :: [elt] -> Bag elt -bagToList :: Bag elt -> [elt] -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[BitSet]{The @BitSet@ type} -\index{BitSet module (GHC syslib)} -%* * -%************************************************************************ - -Bit sets are a fast implementation of sets of integers ranging from 0 -to one less than the number of bits in a machine word (typically 31). -If any element exceeds the maximum value for a particular machine -architecture, the results of these operations are undefined. You have -been warned. [``If you put any safety checks in this code, I will have -to kill you.'' --JSM] - -\begin{verbatim} -mkBS :: [Int] -> BitSet -listBS :: BitSet -> [Int] -emptyBS :: BitSet -unitBS :: Int -> BitSet - -unionBS :: BitSet -> BitSet -> BitSet -minusBS :: BitSet -> BitSet -> BitSet -elementBS :: Int -> BitSet -> Bool -intersectBS :: BitSet -> BitSet -> BitSet - -isEmptyBS :: BitSet -> Bool -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[FiniteMap]{The @FiniteMap@ type} -\index{FiniteMap module (GHC syslib)} -%* * -%************************************************************************ - -What functional programmers call a {\em finite map}, everyone else -calls a {\em lookup table}. - -Out code is derived from that in this paper: -\begin{display} -S Adams -"Efficient sets: a balancing act" -Journal of functional programming 3(4) Oct 1993, pages 553-562 -\end{display} -Guess what? The implementation uses balanced trees. - -\begin{verbatim} --- BUILDING -emptyFM :: FiniteMap key elt -unitFM :: key -> elt -> FiniteMap key elt -listToFM :: Ord key => [(key,elt)] -> FiniteMap key elt - -- In the case of duplicates, the last is taken - --- ADDING AND DELETING - -- Throws away any previous binding - -- In the list case, the items are added starting with the - -- first one in the list -addToFM :: Ord key => FiniteMap key elt -> key -> elt -> FiniteMap key elt -addListToFM :: Ord key => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt - - -- Combines with previous binding -addToFM_C :: Ord key => (elt -> elt -> elt) - -> FiniteMap key elt -> key -> elt - -> FiniteMap key elt -addListToFM_C :: Ord key => (elt -> elt -> elt) - -> FiniteMap key elt -> [(key,elt)] - -> FiniteMap key elt - - -- Deletion doesn't complain if you try to delete something - -- which isn't there -delFromFM :: Ord key => FiniteMap key elt -> key -> FiniteMap key elt -delListFromFM :: Ord key => FiniteMap key elt -> [key] -> FiniteMap key elt - --- COMBINING - -- Bindings in right argument shadow those in the left -plusFM :: Ord key => FiniteMap key elt -> FiniteMap key elt - -> FiniteMap key elt - - -- Combines bindings for the same thing with the given function -plusFM_C :: Ord key => (elt -> elt -> elt) - -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt - -minusFM :: Ord key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt - -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2 - -intersectFM :: Ord key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt -intersectFM_C :: Ord key => (elt -> elt -> elt) - -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt - --- MAPPING, FOLDING, FILTERING -foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a -mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 -filterFM :: Ord key => (key -> elt -> Bool) - -> FiniteMap key elt -> FiniteMap key elt - --- INTERROGATING -sizeFM :: FiniteMap key elt -> Int -isEmptyFM :: FiniteMap key elt -> Bool - -elemFM :: Ord key => key -> FiniteMap key elt -> Bool -lookupFM :: Ord key => FiniteMap key elt -> key -> Maybe elt -lookupWithDefaultFM - :: Ord key => FiniteMap key elt -> elt -> key -> elt - -- lookupWithDefaultFM supplies a "default" elt - -- to return for an unmapped key - --- LISTIFYING -fmToList :: FiniteMap key elt -> [(key,elt)] -keysFM :: FiniteMap key elt -> [key] -eltsFM :: FiniteMap key elt -> [elt] -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[ListSetOps]{The @ListSetOps@ type} -\index{ListSetOps module (GHC syslib)} -%* * -%************************************************************************ - -Just a few set-sounding operations on lists. If you want sets, use -the \tr{Set} module. - -\begin{verbatim} -unionLists :: Eq a => [a] -> [a] -> [a] -intersectLists :: Eq a => [a] -> [a] -> [a] -minusList :: Eq a => [a] -> [a] -> [a] -disjointLists :: Eq a => [a] -> [a] -> Bool -intersectingLists :: Eq a => [a] -> [a] -> Bool -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[Maybes]{The @Maybes@ type} -\index{Maybes module (GHC syslib)} -%* * -%************************************************************************ - -The \tr{Maybe} type itself is in the Haskell~1.3 prelude. Moreover, -the required \tr{Maybe} library provides many useful functions on -\tr{Maybe}s. This (old) module provides more. - -An \tr{Either}-like type called \tr{MaybeErr}: -\begin{verbatim} -data MaybeErr val err = Succeeded val | Failed err -\end{verbatim} - -Some operations to do with \tr{Maybe} (some commentary follows): -\begin{verbatim} -maybeToBool :: Maybe a -> Bool -- Nothing => False; Just => True -allMaybes :: [Maybe a] -> Maybe [a] -firstJust :: [Maybe a] -> Maybe a -findJust :: (a -> Maybe b) -> [a] -> Maybe b - -assocMaybe :: Eq a => [(a,b)] -> a -> Maybe b -mkLookupFun :: (key -> key -> Bool) -- Equality predicate - -> [(key,val)] -- The assoc list - -> (key -> Maybe val) -- A lookup fun to use -mkLookupFunDef :: (key -> key -> Bool) -- Ditto, with a default - -> [(key,val)] - -> val -- the default - -> (key -> val) -- NB: not a Maybe anymore - - -- a monad thing -thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b -returnMaybe :: a -> Maybe a -failMaybe :: Maybe a -mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b] -\end{verbatim} - -NB: @catMaybes@, which used to be here, is in the Haskell~1.3 libraries. - -@allMaybes@ collects a list of @Justs@ into a single @Just@, returning -@Nothing@ if there are any @Nothings@. - -@firstJust@ takes a list of @Maybes@ and returns the -first @Just@ if there is one, or @Nothing@ otherwise. - -@assocMaybe@ looks up in an association list, returning -@Nothing@ if it fails. - -Now, some operations to do with \tr{MaybeErr} (comments follow): -\begin{verbatim} - -- a monad thing (surprise, surprise) -thenMaB :: MaybeErr a err -> (a -> MaybeErr b err) -> MaybeErr b err -returnMaB :: val -> MaybeErr val err -failMaB :: err -> MaybeErr val err - -listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err] -foldlMaybeErrs :: (acc -> input -> MaybeErr acc err) - -> acc - -> [input] - -> MaybeErr acc [err] -\end{verbatim} - -@listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed, -returns a @Succeeded@ of a list of their values. If any fail, it -returns a @Failed@ of the list of all the errors in the list. - -@foldlMaybeErrs@ works along a list, carrying an accumulator; it -applies the given function to the accumulator and the next list item, -accumulating any errors that occur. - -%************************************************************************ -%* * -\subsubsection[PackedString]{The @PackedString@ type} -\index{PackedString module (GHC syslib)} -%* * -%************************************************************************ - -You need \tr{import PackedString}, and -heave in your \tr{-syslib ghc}. - -The basic type and functions which are available are: -\begin{verbatim} -data PackedString - -packString :: [Char] -> PackedString -packStringST :: [Char] -> ST s PackedString -packCString :: Addr -> PackedString -packCBytes :: Int -> Addr -> PackedString -packCBytesST :: Int -> Addr -> ST s PackedString -packBytesForC :: [Char] -> ByteArray Int -packBytesForCST :: [Char] -> ST s (ByteArray Int) -byteArrayToPS :: ByteArray Int -> PackedString -psToByteArray :: PackedString -> ByteArray Int - -unpackPS :: PackedString -> [Char] -\end{verbatim} - -We also provide a wad of list-manipulation-like functions: -\begin{verbatim} -nilPS :: PackedString -consPS :: Char -> PackedString -> PackedString - -headPS :: PackedString -> Char -tailPS :: PackedString -> PackedString -nullPS :: PackedString -> Bool -appendPS :: PackedString -> PackedString -> PackedString -lengthPS :: PackedString -> Int -indexPS :: PackedString -> Int -> Char - -- 0-origin indexing into the string -mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-} -filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-} -foldlPS :: (a -> Char -> a) -> a -> PackedString -> a -foldrPS :: (Char -> a -> a) -> a -> PackedString -> a -takePS :: Int -> PackedString -> PackedString -dropPS :: Int -> PackedString -> PackedString -splitAtPS :: Int -> PackedString -> (PackedString, PackedString) -takeWhilePS:: (Char -> Bool) -> PackedString -> PackedString -dropWhilePS:: (Char -> Bool) -> PackedString -> PackedString -spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) -breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) -linesPS :: PackedString -> [PackedString] -wordsPS :: PackedString -> [PackedString] -reversePS :: PackedString -> PackedString -concatPS :: [PackedString] -> PackedString - -substrPS :: PackedString -> Int -> Int -> PackedString - -- pluck out a piece of a PS - -- start and end chars you want; both 0-origin-specified -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[Pretty]{The @Pretty@ type} -\index{Pretty module (GHC syslib)} -%* * -%************************************************************************ - -This is the pretty-printer that we use in GHC. - -\begin{verbatim} -type Pretty - -ppShow :: Int{-width-} -> Pretty -> [Char] - -pp'SP :: Pretty -- "comma space" -ppComma :: Pretty -- , -ppEquals :: Pretty -- = -ppLbrack :: Pretty -- [ -ppLparen :: Pretty -- ( -ppNil :: Pretty -- nothing -ppRparen :: Pretty -- ) -ppRbrack :: Pretty -- ] -ppSP :: Pretty -- space -ppSemi :: Pretty -- ; - -ppChar :: Char -> Pretty -ppDouble :: Double -> Pretty -ppFloat :: Float -> Pretty -ppInt :: Int -> Pretty -ppInteger :: Integer -> Pretty -ppRational :: Rational -> Pretty -ppStr :: [Char] -> Pretty - -ppAbove :: Pretty -> Pretty -> Pretty -ppAboves :: [Pretty] -> Pretty -ppBeside :: Pretty -> Pretty -> Pretty -ppBesides :: [Pretty] -> Pretty -ppCat :: [Pretty] -> Pretty -ppHang :: Pretty -> Int -> Pretty -> Pretty -ppInterleave :: Pretty -> [Pretty] -> Pretty -- spacing between -ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spacing between -ppNest :: Int -> Pretty -> Pretty -ppSep :: [Pretty] -> Pretty - -ppBracket :: Pretty -> Pretty -- [ ... ] around something -ppParens :: Pretty -> Pretty -- ( ... ) around something -ppQuote :: Pretty -> Pretty -- ` ... ' around something -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[Set]{The @Set@ type} -\index{Set module (GHC syslib)} -%* * -%************************************************************************ - -Our implementation of {\em sets} (key property: no duplicates) is just -a variant of the \tr{FiniteMap} module. - -\begin{verbatim} -mkSet :: Ord a => [a] -> Set a -setToList :: Set a -> [a] -emptySet :: Set a -singletonSet :: a -> Set a - -union :: Ord a => Set a -> Set a -> Set a -unionManySets :: Ord a => [Set a] -> Set a -intersect :: Ord a => Set a -> Set a -> Set a -minusSet :: Ord a => Set a -> Set a -> Set a -mapSet :: Ord a => (b -> a) -> Set b -> Set a - -elementOf :: Ord a => a -> Set a -> Bool -isEmptySet :: Set a -> Bool -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[Util]{The @Util@ type} -\index{Util module (GHC syslib)} -%* * -%************************************************************************ - -Stuff that has been useful to use in writing the compiler. Don't be -too surprised if this stuff moves/gets-renamed/etc. - -\begin{verbatim} --- general list processing -exists :: (a -> Bool) -> [a] -> Bool -forall :: (a -> Bool) -> [a] -> Bool -isSingleton :: [a] -> Bool -lengthExceeds :: [a] -> Int -> Bool -mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) -mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) -nOfThem :: Int -> a -> [a] -zipEqual :: [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] -zipLazy :: [a] -> [b] -> [(a,b)] -- lazy in 2nd arg - --- association lists -assoc :: Eq a => String -> [(a, b)] -> a -> b - --- duplicate handling -hasNoDups :: Eq a => [a] -> Bool -equivClasses :: (a -> a -> Ordering) -> [a] -> [[a]] -runs :: (a -> a -> Bool) -> [a] -> [[a]] -removeDups :: (a -> a -> Ordering) -> [a] -> ([a], [[a]]) - --- sorting (don't complain of no choice...) -quicksort :: (a -> a -> Bool) -> [a] -> [a] -sortLt :: (a -> a -> Bool) -> [a] -> [a] -stableSortLt :: (a -> a -> Bool) -> [a] -> [a] -mergesort :: (a -> a -> Ordering) -> [a] -> [a] -mergeSort :: Ord a => [a] -> [a] -naturalMergeSort :: Ord a => [a] -> [a] -mergeSortLe :: Ord a => [a] -> [a] -naturalMergeSortLe :: Ord a => [a] -> [a] - --- transitive closures -transitiveClosure :: (a -> [a]) -- Successor function - -> (a -> a -> Bool) -- Equality predicate - -> [a] - -> [a] -- The transitive closure - --- accumulating (Left, Right, Bi-directional) -mapAccumL :: (acc -> x -> (acc, y)) - -- Function of elt of input list and - -- accumulator, returning new accumulator and - -- elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list - -mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) - -mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) - -> accl -> accr -> [x] - -> (accl, accr, [y]) - --- comparisons -cmpString :: String -> String -> Ordering - --- pairs -applyToPair :: ((a -> c), (b -> d)) -> (a, b) -> (c, d) -applyToFst :: (a -> c) -> (a, b) -> (c, b) -applyToSnd :: (b -> d) -> (a, b) -> (a, d) -foldPair :: (a->a->a, b->b->b) -> (a, b) -> [(a, b)] -> (a, b) -unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -\end{verbatim} - -%************************************************************************ -%* * -\subsection[C-interfaces]{Interfaces to C libraries} -\index{C library interfaces} -\index{interfaces, C library} -%* * -%************************************************************************ - -The GHC system library (\tr{-syslib ghc}) also provides interfaces to -several useful C libraries, mostly from the GNU project. - -%************************************************************************ -%* * -\subsubsection[Readline]{The @Readline@ interface} -\index{Readline library (GHC syslib)} -\index{command-line editing library} -%* * -%************************************************************************ - -(Darren Moffat supplied the \tr{Readline} interface.) - -The \tr{Readline} module is a straightforward interface to the GNU -Readline library. As such, you will need to look at the GNU -documentation (and have a \tr{libreadline.a} file around somewhere...) - -You'll need to link any Readlining program with \tr{-lreadline -ltermcap}, -besides the usual \tr{-syslib ghc}. - -The main function you'll use is: -\begin{verbatim} -readline :: String{-the prompt-} -> IO String -\end{verbatim} - -If you want to mess around with Full Readline G(l)ory, we also -provide: -\begin{verbatim} -rlInitialize, addHistory, - -rlBindKey, rlAddDefun, RlCallbackFunction(..), - -rlGetLineBuffer, rlSetLineBuffer, rlGetPoint, rlSetPoint, rlGetEnd, -rlSetEnd, rlGetMark, rlSetMark, rlSetDone, rlPendingInput, - -rlPrompt, rlTerminalName, rlSetReadlineName, rlGetReadlineName -\end{verbatim} -(All those names are just Haskellised versions of what you -will see in the GNU readline documentation.) - -%************************************************************************ -%* * -\subsubsection[Regexp]{The @Regexp@ and @MatchPS@ interfaces} -\index{Regex library (GHC syslib)} -\index{MatchPS library (GHC syslib)} -\index{regular-expressions library} -%* * -%************************************************************************ - -(Sigbjorn Finne supplied the regular-expressions interface.) - -The \tr{Regex} library provides quite direct interface to the GNU -regular-expression library, for doing manipulation on -\tr{PackedString}s. You probably need to see the GNU documentation -if you are operating at this level. - -The datatypes and functions that \tr{Regex} provides are: -\begin{verbatim} -data PatBuffer # just a bunch of bytes (mutable) - -data REmatch - = REmatch (Array Int GroupBounds) -- for $1, ... $n - GroupBounds -- for $` (everything before match) - GroupBounds -- for $& (entire matched string) - GroupBounds -- for $' (everything after) - GroupBounds -- for $+ (matched by last bracket) - --- GroupBounds hold the interval where a group --- matched inside a string, e.g. --- --- matching "reg(exp)" "a regexp" returns the pair (5,7) for the --- (exp) group. (PackedString indices start from 0) - -type GroupBounds = (Int, Int) - -re_compile_pattern - :: PackedString -- pattern to compile - -> Bool -- True <=> assume single-line mode - -> Bool -- True <=> case-insensitive - -> PrimIO PatBuffer - -re_match :: PatBuffer -- compiled regexp - -> PackedString -- string to match - -> Int -- start position - -> Bool -- True <=> record results in registers - -> PrimIO (Maybe REmatch) - --- Matching on 2 strings is useful when you're dealing with multiple --- buffers, which is something that could prove useful for --- PackedStrings, as we don't want to stuff the contents of a file --- into one massive heap chunk, but load (smaller chunks) on demand. - -re_match2 :: PatBuffer -- 2-string version - -> PackedString - -> PackedString - -> Int - -> Int - -> Bool - -> PrimIO (Maybe REmatch) - -re_search :: PatBuffer -- compiled regexp - -> PackedString -- string to search - -> Int -- start index - -> Int -- stop index - -> Bool -- True <=> record results in registers - -> PrimIO (Maybe REmatch) - -re_search2 :: PatBuffer -- Double buffer search - -> PackedString - -> PackedString - -> Int -- start index - -> Int -- range (?) - -> Int -- stop index - -> Bool -- True <=> results in registers - -> PrimIO (Maybe REmatch) -\end{verbatim} - -The \tr{MatchPS} module provides Perl-like ``higher-level'' facilities -to operate on \tr{PackedStrings}. The regular expressions in -question are in Perl syntax. The ``flags'' on various functions can -include: \tr{i} for case-insensitive, \tr{s} for single-line mode, and -\tr{g} for global. (It's probably worth your time to peruse the -source code...) - -\begin{verbatim} -matchPS :: PackedString -- regexp - -> PackedString -- string to match - -> [Char] -- flags - -> Maybe REmatch -- info about what matched and where - -searchPS :: PackedString -- regexp - -> PackedString -- string to match - -> [Char] -- flags - -> Maybe REmatch - --- Perl-like match-and-substitute: -substPS :: PackedString -- regexp - -> PackedString -- replacement - -> [Char] -- flags - -> PackedString -- string - -> PackedString - --- same as substPS, but no prefix and suffix: -replacePS :: PackedString -- regexp - -> PackedString -- replacement - -> [Char] -- flags - -> PackedString -- string - -> PackedString - -match2PS :: PackedString -- regexp - -> PackedString -- string1 to match - -> PackedString -- string2 to match - -> [Char] -- flags - -> Maybe REmatch - -search2PS :: PackedString -- regexp - -> PackedString -- string to match - -> PackedString -- string to match - -> [Char] -- flags - -> Maybe REmatch - --- functions to pull the matched pieces out of an REmatch: - -getMatchesNo :: REmatch -> Int -getMatchedGroup :: REmatch -> Int -> PackedString -> PackedString -getWholeMatch :: REmatch -> PackedString -> PackedString -getLastMatch :: REmatch -> PackedString -> PackedString -getAfterMatch :: REmatch -> PackedString -> PackedString - --- (reverse) brute-force string matching; --- Perl equivalent is index/rindex: -findPS, rfindPS :: PackedString -> PackedString -> Maybe Int - --- Equivalent to Perl "chop" (off the last character, if any): -chopPS :: PackedString -> PackedString - --- matchPrefixPS: tries to match as much as possible of strA starting --- from the beginning of strB (handy when matching fancy literals in --- parsers): -matchPrefixPS :: PackedString -> PackedString -> Int -\end{verbatim} - -%************************************************************************ -%* * -\subsubsection[Socket]{Network-interface toolkit---@Socket@ and @SocketPrim@} -\index{SocketPrim interface (GHC syslib)} -\index{Socket interface (GHC syslib)} -\index{network-interface library} -\index{sockets library} -\index{BSD sockets library} -%* * -%************************************************************************ - -(Darren Moffat supplied the network-interface toolkit.) - -Your best bet for documentation is to look at the code---really!--- -normally in \tr{hslibs/ghc/src/{BSD,Socket,SocketPrim}.lhs}. - -The \tr{BSD} module provides functions to get at system-database info; -pretty straightforward if you're into this sort of thing: -\begin{verbatim} -getHostName :: IO String - -getServiceByName :: ServiceName -> IO ServiceEntry -getServicePortNumber:: ServiceName -> IO PortNumber -getServiceEntry :: IO ServiceEntry -setServiceEntry :: Bool -> IO () -endServiceEntry :: IO () - -getProtocolByName :: ProtocolName -> IO ProtocolEntry -getProtocolByNumber :: ProtocolNumber -> IO ProtcolEntry -getProtocolNumber :: ProtocolName -> ProtocolNumber -getProtocolEntry :: IO ProtocolEntry -setProtocolEntry :: Bool -> IO () -endProtocolEntry :: IO () - -getHostByName :: HostName -> IO HostEntry -getHostByAddr :: Family -> HostAddress -> IO HostEntry -getHostEntry :: IO HostEntry -setHostEntry :: Bool -> IO () -endHostEntry :: IO () -\end{verbatim} - -The \tr{SocketPrim} interface provides quite direct access to the -socket facilities in a BSD Unix system, including all the -complications. We hope you don't need to use it! See the source if -needed... - -The \tr{Socket} interface is a ``higher-level'' interface to sockets, -and it is what we recommend. Please tell us if the facilities it -offers are inadequate to your task! - -The interface is relatively modest: -\begin{verbatim} -connectTo :: Hostname -> PortID -> IO Handle -listenOn :: PortID -> IO Socket - -accept :: Socket -> IO (Handle, HostName) -sendTo :: Hostname -> PortID -> String -> IO () - -recvFrom :: Hostname -> PortID -> IO String -socketPort :: Socket -> IO PortID - -data PortID -- PortID is a non-abstract type - = Service String -- Service Name eg "ftp" - | PortNumber Int -- User defined Port Number - | UnixSocket String -- Unix family socket in file system - -type Hostname = String -\end{verbatim} - -Various examples of networking Haskell code are provided in -\tr{ghc/misc/examples/}, notably the \tr{net???/Main.hs} programs. - -%************************************************************************ -%* * -\subsection[HBC-library]{The HBC system library} -\index{HBC system library} -\index{system library, HBC} -%* * -%************************************************************************ - -This documentation is stolen directly from the HBC distribution. The -modules that GHC does not support (because they require HBC-specific -extensions) are omitted. +\documentstyle[a4wide,grasp]{article} +\renewcommand{\textfraction}{0.1} +\renewcommand{\floatpagefraction}{0.9} +\renewcommand{\dblfloatpagefraction}{0.9} +\sloppy +\renewcommand{\today}{March 1997} + +\begin{document} + +\title{The GHC Prelude and Libraries} +\author{Simon L Peyton Jones \and Will Partain} + +\maketitle +\tableofcontents + +\section{Introduction} + +This document describes GHC's prelude and libraries. The basic story is that of +the Haskell 1.3 Report and Libraries document (which we do not reproduce here), +but this document describes in addition: +\begin{itemize} +\item GHC's additional non-standard libraries and types, such as state transformers, + packed strings, foreign objects, stable pointers, and so on. + +\item GHC's primitive types and operations. The standard Haskell functions are implemented + on top of these, and it is sometimes useful to use them directly. + +\item The organsiation of these libraries into directories. +\end{itemize} + +\section{Overview} + +The libraries are organised into the following three groups, each of which +is kept in a separate sub-directory of GHC's installed @lib/@ directory: \begin{description} -\item[\tr{ListUtil}:] -\index{ListUtil module (HBC library)}% -Various useful functions involving lists that are missing from the -\tr{Prelude}: -\begin{verbatim} -assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b - -- assoc f d l k looks for k in the association list l, if it - -- is found f is applied to the value, otherwise d is returned. -concatMap :: (a -> [b]) -> [a] -> [b] - -- flattening map (LML's concmap) -unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] - -- unfoldr f p x repeatedly applies f to x until (p x) holds. - -- (f x) should give a list element and a new x. -mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) - -- mapAccuml f s l maps f over l, but also threads the state s - -- through (LML's mapstate). -union :: (Eq a) => [a] -> [a] -> [a] - -- union of two lists -intersection :: (Eq a) => [a] -> [a] -> [a] - -- intersection of two lists -chopList :: ([a] -> (b, [a])) -> [a] -> [b] - -- LMLs choplist -assocDef :: (Eq a) => [(a, b)] -> b -> a -> b - -- LMLs assocdef -lookup :: (Eq a) => [(a, b)] -> a -> Option b - -- lookup l k looks for the key k in the association list l - -- and returns an optional value -tails :: [a] -> [[a]] - -- return all the tails of a list -rept :: (Integral a) => a -> b -> [b] - -- repeat a value a number of times -groupEq :: (a->a->Bool) -> [a] -> [[a]] - -- group list elements according to an equality predicate -group :: (Eq a) => [a] -> [[a]] - -- group according to} == -readListLazily :: (Read a) => String -> [a] - -- read a list in a lazy fashion -\end{verbatim} - -\item[\tr{Pretty}:] -\index{Pretty module (HBC library)}% -John Hughes's pretty printing library. -\begin{verbatim} -type Context = (Bool, Int, Int, Int) -type IText = Context -> [String] -text :: String -> IText -- just text -(~.) :: IText -> IText -> IText -- horizontal composition -(^.) :: IText -> IText -> IText -- vertical composition -separate :: [IText] -> IText -- separate by spaces -nest :: Int -> IText -> IText -- indent -pretty :: Int -> Int -> IText -> String -- format it -\end{verbatim} - -\item[\tr{QSort}:] -\index{QSort module (HBC library)}% -A sort function using quicksort. -\begin{verbatim} -sortLe :: (a -> a -> Bool) -> [a] -> [a] - -- sort le l sorts l with le as less than predicate -sort :: (Ord a) => [a] -> [a] - -- sort l sorts l using the Ord class -\end{verbatim} - -\item[\tr{Random}:] -\index{Random module (HBC library)}% -Random numbers. -\begin{verbatim} -randomInts :: Int -> Int -> [Int] - -- given two seeds gives a list of random Int -randomDoubles :: Int -> Int -> [Double] - -- random Double with uniform distribution in (0,1) -normalRandomDoubles :: Int -> Int -> [Double] - -- random Double with normal distribution, mean 0, variance 1 -\end{verbatim} - -\item[\tr{Trace}:] -Simple tracing. (Note: This comes with GHC anyway.) -\begin{verbatim} -trace :: String -> a -> a -- trace x y prints x and returns y -\end{verbatim} - -\item[\tr{Miranda}:] -\index{Miranda module (HBC library)}% -Functions found in the Miranda library. -(Note: Miranda is a registered trade mark of Research Software Ltd.) - -\item[\tr{Word}:] -\index{Word module (HBC library)} -Bit manipulation. (GHC doesn't implement absolutely all of this. -And don't count on @Word@ being 32 bits on a Alpha...) -\begin{verbatim} -class Bits a where - bitAnd :: a -> a -> a -- bitwise and - bitOr :: a -> a -> a -- bitwise or - bitXor :: a -> a -> a -- bitwise xor - bitCompl :: a -> a -- bitwise negation - bitRsh :: a -> Int -> a -- bitwise right shift - bitLsh :: a -> Int -> a -- bitwise left shift - bitSwap :: a -> a -- swap word halves - bit0 :: a -- word with least significant bit set - bitSize :: a -> Int -- number of bits in a word - -data Byte -- 8 bit quantity -data Short -- 16 bit quantity -data Word -- 32 bit quantity - -instance Bits Byte, Bits Short, Bits Word -instance Eq Byte, Eq Short, Eq Word -instance Ord Byte, Ord Short, Ord Word -instance Show Byte, Show Short, Show Word -instance Num Byte, Num Short, Num Word -wordToShorts :: Word -> [Short] -- convert a Word to two Short -wordToBytes :: Word -> [Byte] -- convert a Word to four Byte -bytesToString :: [Byte] -> String -- convert a list of Byte to a String (bit by bit) -wordToInt :: Word -> Int -- convert a Word to Int -shortToInt :: Short -> Int -- convert a Short to Int -byteToInt :: Byte -> Int -- convert a Byte to Int -\end{verbatim} - -\item[\tr{Time}:] -\index{Time module (HBC library)}% -Manipulate time values (a Double with seconds since 1970). -\begin{verbatim} --- year mon day hour min sec dec-sec weekday -data Time = Time Int Int Int Int Int Int Double Int -dblToTime :: Double -> Time -- convert a Double to a Time -timeToDbl :: Time -> Double -- convert a Time to a Double -timeToString :: Time -> String -- convert a Time to a readable String -\end{verbatim} - -\item[\tr{Hash}:] -\index{Hash module (HBC library)}% -Hashing functions. -\begin{verbatim} -class Hashable a where - hash :: a -> Int -- hash a value, return an Int --- instances for all Prelude types -hashToMax :: (Hashable a) => Int -> a -> Int -- hash into interval [0..x-1] -\end{verbatim} - -\item[\tr{NameSupply}:] -\index{NameSupply module (HBC library)}% -Functions to generate unique names (Int). -\begin{verbatim} -type Name = Int -initialNameSupply :: NameSupply - -- The initial name supply (may be different every - -- time the program is run. -splitNameSupply :: NameSupply -> (NameSupply,NameSupply) - -- split the namesupply into two -getName :: NameSupply -> Name - -- get the name associated with a name supply -\end{verbatim} - -\item[\tr{Parse}:] -\index{Parse module (HBC library)}% -Higher order functions to build parsers. With a little care these -combinators can be used to build efficient parsers with good error -messages. -\begin{verbatim} -infixr 8 +.+ , ..+ , +.. -infix 6 `act` , >>> , `into` , .> -infixr 4 ||| , ||! , |!! -data ParseResult a b -type Parser a b = a -> Int -> ParseResult a b -(|||) :: Parser a b -> Parser a b -> Parser a b - -- Alternative -(||!) :: Parser a b -> Parser a b -> Parser a b - -- Alternative, but with committed choice -(|!!) :: Parser a b -> Parser a b -> Parser a b - -- Alternative, but with committed choice -(+.+) :: Parser a b -> Parser a c -> Parser a (b,c) - -- Sequence -(..+) :: Parser a b -> Parser a c -> Parser a c - -- Sequence, throw away first part -(+..) :: Parser a b -> Parser a c -> Parser a b - -- Sequence, throw away second part -act :: Parser a b -> (b->c) -> Parser a c - -- Action -(>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d - -- Action on two items -(.>) :: Parser a b -> c -> Parse a c - -- Action ignoring value -into :: Parser a b -> (b -> Parser a c) -> Parser a c - -- Use a produced value in a parser. -succeed b :: Parser a b - -- Always succeeds without consuming a token -failP :: Parser a b - -- Always fails. -many :: Parser a b -> Parser a [b] - -- Kleene star -many1 :: Parser a b -> Parser a [b] - -- Kleene plus -count :: Parser a b -> Int -> Parser a [b] - -- Parse an exact number of items -sepBy1 :: Parser a b -> Parser a c -> Parser a [b] - -- Non-empty sequence of items separated by something -sepBy :: Parser a b -> Parser a c -> Parser a [b] - -- Sequence of items separated by something -lit :: (Eq a, Show a) => a -> Parser [a] a - -- Recognise a literal token from a list of tokens -litp :: String -> (a->Bool) -> Parser [a] a - -- Recognise a token with a predicate. - -- The string is a description for error messages. -testp :: String -> (a -> Bool) -> (Parser b a) -> Parser b a - -- Test a semantic value. -token :: (a -> Either String (b, a)) -> Parser a b - -- General token recogniser. -parse :: Parser a b -> a -> Either ([String], a) [(b, a)] - -- Do a parse. Return either error (possible tokens and rest - -- of tokens) or all possible parses. -sParse :: (Show a) => (Parser [a] b) -> [a] -> Either String b - -- Simple parse. Return error message or result. -\end{verbatim} - -%%%simpleLex :: String -> [String] -- A simple (but useful) lexical analyzer - -\item[\tr{Native}:] -\index{Native module (HBC library)}% -Functions to convert the primitive types \tr{Int}, \tr{Float}, and \tr{Double} to -their native representation as a list of bytes (\tr{Char}). If such a list -is read/written to a file it will have the same format as when, e.g., -C read/writes the same kind of data. -\begin{verbatim} -type Bytes = [Char] -- A byte stream is just a list of characters - -class Native a where - showBytes :: a -> Bytes -> Bytes - -- prepend the representation of an item the a byte stream - listShowBytes :: [a] -> Bytes -> Bytes - -- prepend the representation of a list of items to a stream - -- (may be more efficient than repeating showBytes). - readBytes :: Bytes -> Maybe (a, Bytes) - -- get an item from the stream and return the rest, - -- or fail if the stream is to short. - listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes) - -- read n items from a stream. - -instance Native Int -instance Native Float -instance Native Double -instance (Native a, Native b) => Native (a,b) - -- juxtaposition of the two items -instance (Native a, Native b, Native c) => Native (a, b, c) - -- juxtaposition of the three items -instance (Native a) => Native [a] - -- an item count in an Int followed by the items - -shortIntToBytes :: Int -> Bytes -> Bytes - -- Convert an Int to what corresponds to a short in C. -bytesToShortInt :: Bytes -> Maybe (Int, Bytes) - -- Get a short from a byte stream and convert to an Int. - -showB :: (Native a) => a -> Bytes -- Simple interface to showBytes. -readB :: (Native a) => Bytes -> a -- Simple interface to readBytes. -\end{verbatim} - -\item[\tr{Number}:] -\index{Number module (HBC library)}% -Simple numbers that belong to all numeric classes and behave like -a naive user would expect (except that printing is still ugly). -(NB: GHC does not provide a magic way to use \tr{Numbers} everywhere, -but you should be able to do it with normal \tr{import}ing and -\tr{default}ing.) -\begin{verbatim} -data Number -- The type itself. -instance ... -- All reasonable instances. -isInteger :: Number -> Bool -- Test if a Number is an integer. -\end{verbatim} +\item[@lib/required/@] These are the libraries {\em required} by the Haskell +definition. All are defined by the Haskell Report, or by the Haskell Libraries Report. +They currently comprise: +\begin{itemize} +\item @Prelude@. +\item @List@: more functions on lists. +\item @Char@: more functions on characters. +\item @Maybe@: more functions on @Maybe@ types. +\item @Complex@: functions on complex numbers. +\item @Ratio@: functions on rational numbers. +\item @Monad@: functions on characters. +\item @Ix@: the @Ix@ class of indexing operations. +\item @Array@: monolithic arrays. +\item @IO@: basic input/output functions. +\item @Directory@: basic functions for accessing the file system. +\item @System@: basic operating-system interface functions. +\end{itemize} + +\item[@lib/glaExts@] GHC extension libraries, currently comprising: +\begin{itemize} +\item @PackedString@: functions that manipulate strings packed efficiently, one character per byte. +\item @ST@: the state transformer monad. +\item @Foreign@: types and operations for GHC's foreign-language interface. +\end{itemize} + +\item[@lib/concurrent@] GHC extension libraries to support Concurrent Haskell, currently comprising: +\begin{itemize} +\item @Concurrent.hs@: main library. +\item @Parallel.hs@: stuff for multi-processor parallelism. +\item @Channel.hs@ +\item @ChannelVar.hs@ +\item @Merge.hs@ +\item @SampleVar.hs@ +\item @Semaphore.hs@ +\end{itemize} + +\item[@lib/ghc@] These libraries are the pieces on which all the others are built. +They aren't typically imported by Joe Programmer, but there's nothing to stop you +doing so if you want. In general, the modules prefixed by @Prel@ are pieces that go +towards building @Prelude@. + +\begin{itemize} +\item @GHC@: this ``library'' brings into scope all the primitive types and operations, such as +@Int#@, @+#@, @encodeFloat#@, etc etc. It is unique in that there is no Haskell +source code for it. Details in Section \ref{sect:ghc}. + +\item @PrelBase@: defines the basic types and classes without which very few Haskell programs can work. +The classes are: @Eq@, @Ord@, @Enum@, @Bounded@, @Num@, @Show@, @Eval@, @Monad@, @MonadZero@, @MonadPlus@. +The types are: list, @Bool@, @Char@, @Ordering@, @String@, @Int@, @Integer@, @Maybe@, @Either@. + +\item @PrelTup@: defines tuples and their instances. +\item @PrelList@: defines most of the list operations required by @Prelude@. (A few are in @PrelBase@, +to avoid gratuitous mutual recursion between modules.) + +\item @PrelNum@ defines: the numeric classes beyond @Num@ (namely @Real@, @Integral@, +@Fractional@, @Floating@, @RealFrac@, @RealFloat@; instances for appropriate classes +for @Int@ and @Integer@; the types @Float@, @Double@, and @Ratio@ and their instances. + +\item @PrelRead@: the @Read@ class and all its instances. It's kept separate because many programs +don't use @Read@ at all, so we don't even want to link in its code. + +\item @ConcBase@: substrate stuff for Concurrent Haskell. + +\item @IOBase@: substrate stuff for the main I/O libraries. +\item @IOHandle@: large blob of code for doing I/O on handles. +\item @PrelIO@: the remaining small pieces to produce the I/O stuff needed by @Prelude@. + +\item @STBase@: substrate stuff for @ST@. +\item @ArrBase@: substrate stuff for @Array@. + +\item @GHCerr@: error reporting code, called from code that the compiler plants in compiled programs. +\item @GHCmain@: the definition of @mainPrimIO@, which is what {\em really} gets + called by the runtime system. @mainPrimIO@ in turn calls @main@. +\end{itemize} \end{description} -%************************************************************************ -%* * -\subsection[contrib-library]{The `contrib' system library} -\index{contrib system library} -\index{system library, contrib} -%* * -%************************************************************************ - -Just for a bit of fun, we took all the old contributed ``Haskell -library'' code---Stephen J.~Bevan the main hero, converted it to -Haskell~1.3 and heaved it into a \tr{contrib} system library. It is -mostly code for numerical methods (@SetMap@ is an exception); we have -{\em no idea} whether it is any good or not. - -The modules provided are: -@Adams_Bashforth_Approx@, -@Adams_Predictor_Corrector_Approx@, -@Choleski_Factorization@, -@Crout_Reduction@, -@Cubic_Spline@, -@Fixed_Point_Approx@, -@Gauss_Seidel_Iteration@, -@Hermite_Interpolation@, -@Horner@, -@Jacobi_Iteration@, -@LLDecompMethod@, -@Least_Squares_Fit@, -@Matrix_Ops@, -@Neville_Iterated_Interpolation@, -@Newton_Cotes@, -@Newton_Interpolatory_Divided_Difference@, -@Newton_Raphson_Approx@, -@Runge_Kutta_Approx@, -@SOR_Iteration@, -@Secant_Approx@, -@SetMap@, -@Steffensen_Approx@, -@Taylor_Approx@, and -@Vector_Ops@. +The @...Base@ modules generally export representation information that +is hidden from the public interface. For example the module @STBase@ +exports the type @ST@ including its representation, whereas the module +@ST@ exports @ST@ abstractly. + +None of these modules are involved in any mutual recursion, with the sole exception that +many modules import @IOBase.error@. + +\section{The module @GHC@: really primitive stuff} +\label{sect:ghc} + +This section defines all the types which are primitive in Glasgow Haskell, and the +operations provided for them. + +A primitive type is one which cannot be defined in Haskell, and which +is therefore built into the language and compiler. Primitive types +are always unboxed; that is, a value of primitive type cannot be +bottom. + +Primitive values are often represented by a simple bit-pattern, such as @Int#@, +@Float#@, @Double#@. But this is not necessarily the case: a primitive value +might be represented by a pointer to a heap-allocated object. Examples include +@Array#@, the type of primitive arrays. You might think this odd: doesn't being +heap-allocated mean that it has a box? No, it does not. A primitive array is +heap-allocated because it is too big a value to fit in a register, and would be +too expensive to copy around; in a sense, it is accidental that it is represented +by a pointer. If a pointer represents a primitive value, then it really does +point to that value: no unevaluated thunks, no indirections...nothing can be at +the other end of the pointer than the primitive value. + +This section also describes a few non-primitive types, which are needed +to express the result types of some primitive operations. + +\subsection{Character and numeric types} + +There are the following obvious primitive types: +@ +type Char# +type Int# -- see also Word# and Addr#, later +type Float# +type Double# +@ +If you want to know their exact equivalents in C, see +@ghc/includes/StgTypes.lh@ in the GHC source. + +Literals for these types may be written as follows: +@ +1# an Int# +1.2# a Float# +1.34## a Double# +'a'# a Char#; for weird characters, use '\o<octal>'# +"a"# an Addr# (a `char *') +@ + +\subsubsection{Comparison operations} +@ +{gt,ge,eq,ne,lt,le}Char# :: Char# -> Char# -> Bool + -- ditto for Int#, Word#, Float#, Double#, and Addr# +@ + +\subsubsection{Unboxed-character operations} +@ +ord# :: Char# -> Int# +chr# :: Int# -> Char# +@ + +\subsubsection{Unboxed-@Int@ operations} +@ +{plus,minus,times,quot,div,rem}Int# :: Int# -> Int# -> Int# +negateInt# :: Int# -> Int# +@ +NB: No error/overflow checking! + +\subsubsection{Unboxed-@Double@ and @Float@ operations} +@ +{plus,minus,times,divide}Double# :: Double# -> Double# -> Double# +negateDouble# :: Double# -> Double# + +float2Int# :: Double# -> Int# -- just a cast, no checking! +int2Double# :: Int# -> Double# + +expDouble# :: Double# -> Double# +logDouble# :: Double# -> Double# +sqrtDouble# :: Double# -> Double# +sinDouble# :: Double# -> Double# +cosDouble# :: Double# -> Double# +tanDouble# :: Double# -> Double# +asinDouble# :: Double# -> Double# +acosDouble# :: Double# -> Double# +atanDouble# :: Double# -> Double# +sinhDouble# :: Double# -> Double# +coshDouble# :: Double# -> Double# +tanhDouble# :: Double# -> Double# +powerDouble# :: Double# -> Double# -> Double# +@ +There's an exactly-matching set of unboxed-@Float@ ops; replace +@Double#@ with @Float#@ in the list above. There are two +coercion functions for @Float#@/@Double#@: +@ +float2Double# :: Float# -> Double# +double2Float# :: Double# -> Float# +@ +The primitive versions of @encodeDouble@/@decodeDouble@: +@ +encodeDouble# :: Int# -> Int# -> ByteArray# -- Integer mantissa + -> Int# -- Int exponent + -> Double# + +decodeDouble# :: Double# + -> GHCbase.ReturnIntAndGMP +@ +(And the same for @Float#@s.) + +\subsection{Operations on/for @Integers@ (interface to GMP)} +\label{sect:horrid-Integer-pairing-types} + +We implement @Integers@ (arbitrary-precision integers) using the GNU +multiple-precision (GMP) package. + +NB: some of this might change if we upgrade to using GMP~2.x. + +The data type for @Integer@ must mirror that for @MP_INT@ in @gmp.h@ +(see @gmp.info@). It comes out as: +@ +data Integer = J# Int# Int# ByteArray# +@ +So, @Integer@ is really just a ``pairing'' type for a particular +collection of primitive types. + +The operations in the GMP return other combinations of +GMP-plus-something, so we need ``pairing'' types for those, too: +@ +data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray# +data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray# + +-- ????? something to return a string of bytes (in the heap?) +@ +The primitive ops to support @Integers@ use the ``pieces'' of the +representation, and are as follows: +@ +negateInteger# :: Int# -> Int# -> ByteArray# -> Integer + +{plus,minus,times}Integer# :: Int# -> Int# -> ByteArray# + -> Int# -> Int# -> ByteArray# + -> Integer + +cmpInteger# :: Int# -> Int# -> ByteArray# + -> Int# -> Int# -> ByteArray# + -> Int# -- -1 for <; 0 for ==; +1 for > + +divModInteger#, quotRemInteger# + :: Int# -> Int# -> ByteArray# + -> Int# -> Int# -> ByteArray# + -> GHCbase.Return2GMPs + +integer2Int# :: Int# -> Int# -> ByteArray# + -> Int# + +int2Integer# :: Int# -> Integer -- NB: no error-checking on these two! +word2Integer# :: Word# -> Integer + +addr2Integer# :: Addr# -> Integer + -- the Addr# is taken to be a `char *' string + -- to be converted into an Integer +@ + + +\subsection{Words and addresses} + +A @Word#@ is used for bit-twiddling operations. It is the same size as +an @Int#@, but has no sign nor any arithmetic operations. +@ +type Word# -- Same size/etc as Int# but *unsigned* +type Addr# -- A pointer from outside the "Haskell world" (from C, probably); + -- described under "arrays" +@ +@Word#@s and @Addr#@s have the usual comparison operations. +Other unboxed-@Word@ ops (bit-twiddling and coercions): +@ +and#, or# :: Word# -> Word# -> Word# + +not# :: Word# -> Word# + +shiftL#, shiftRA#, shiftRL# :: Word# -> Int# -> Word# + -- shift left, right arithmetic, right logical + +iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int# + -- same shift ops, but on Int#s + +int2Word# :: Int# -> Word# -- just a cast, really +word2Int# :: Word# -> Int# +@ + +Unboxed-@Addr@ ops (C casts, really): +@ +int2Addr# :: Int# -> Addr# +addr2Int# :: Addr# -> Int# +@ +Operations for indexing off of C pointers (@Addr#@s) to snatch values +are listed under ``arrays''. + +\subsection{Arrays} + +The type @Array# elt@ is the type of primitive, +unboxed arrays of values of type @elt@. +@ +type Array# elt +@ +@Array#@ is more primitive than a Haskell +array --- indeed, Haskell arrays are implemented using @Array#@ --- +in that an @Array#@ is indexed only by @Int#@s, starting at zero. It is also +more primitive by virtue of being unboxed. That doesn't mean that it isn't +a heap-allocated object --- of course, it is. Rather, being unboxed means +that it is represented by a pointer to the array itself, and not to a thunk +which will evaluate to the array (or to bottom). +The components of an @Array#@ are themselves boxed. + +The type @ByteArray#@ is similar to @Array#@, except that it contains +just a string of (non-pointer) bytes. +@ +type ByteArray# +@ +Arrays of these types are useful when a Haskell program wishes to +construct a value to pass to a C procedure. It is also possible to +use them to build (say) arrays of unboxed characters for internal use +in a Haskell program. Given these uses, @ByteArray#@ is deliberately +a bit vague about the type of its components. Operations are provided +to extract values of type @Char#@, @Int#@, @Float#@, @Double#@, and +@Addr#@ from arbitrary offsets within a @ByteArray#@. (For type @Foo#@, +the $i$th offset gets you the $i$th @Foo#@, not the @Foo#@ at byte-position $i$. Mumble.) +(If you want a @Word#@, grab an @Int#@, then coerce it.) + +Lastly, we have static byte-arrays, of type @Addr#@ [mentioned +previously]. (Remember the duality between arrays and pointers in C.) +Arrays of this types are represented by a pointer to an array in the +world outside Haskell, so this pointer is not followed by the garbage +collector. In other respects they are just like @ByteArray#@. They +are only needed in order to pass values from C to Haskell. + +\subsubsection{Reading and writing.} + +Primitive arrays are linear, and indexed starting at zero. + +The size and indices of a @ByteArray#@, @Addr#@, and +@MutableByteArray#@ are all in bytes. It's up to the program to +calculate the correct byte offset from the start of the array. This +allows a @ByteArray#@ to contain a mixture of values of different +type, which is often needed when preparing data for and unpicking +results from C. (Umm... not true of indices... WDP 95/09) + +{\em Should we provide some @sizeOfDouble#@ constants?} + +Out-of-range errors on indexing should be caught by the code which +uses the primitive operation; the primitive operations themselves do +{\em not} check for out-of-range indexes. The intention is that the +primitive ops compile to one machine instruction or thereabouts. + +We use the terms ``reading'' and ``writing'' to refer to accessing {\em mutable} +arrays (see Section~\ref{sect:mutable}), and ``indexing'' +to refer to reading a value from an {\em immutable} +array. + +If you want to read/write a @Word#@, read an @Int#@ and coerce. + +Immutable byte arrays are straightforward to index (all indices in bytes): +@ +indexCharArray# :: ByteArray# -> Int# -> Char# +indexIntArray# :: ByteArray# -> Int# -> Int# +indexAddrArray# :: ByteArray# -> Int# -> Addr# +indexFloatArray# :: ByteArray# -> Int# -> Float# +indexDoubleArray# :: ByteArray# -> Int# -> Double# + +indexCharOffAddr# :: Addr# -> Int# -> Char# +indexIntOffAddr# :: Addr# -> Int# -> Int# +indexFloatOffAddr# :: Addr# -> Int# -> Float# +indexDoubleOffAddr# :: Addr# -> Int# -> Double# +indexAddrOffAddr# :: Addr# -> Int# -> Addr# -- Get an Addr# from an Addr# offset +@ +The last of these, @indexAddrOffAddr#@, extracts an @Addr#@ using an offset +from another @Addr#@, thereby providing the ability to follow a chain of +C pointers. + +Something a bit more interesting goes on when indexing arrays of boxed +objects, because the result is simply the boxed object. So presumably +it should be entered --- we never usually return an unevaluated +object! This is a pain: primitive ops aren't supposed to do +complicated things like enter objects. The current solution is to +return a lifted value, but I don't like it! +@ +indexArray# :: Array# elt -> Int# -> GHCbase.Lift elt -- Yuk! +@ + +\subsubsection{The state type} + +The primitive type @State#@ represents the state of a state transformer. +It is parameterised on the desired type of state, which serves to keep +states from distinct threads distinct from one another. But the {\em only} +effect of this parameterisation is in the type system: all values of type +@State#@ are represented in the same way. Indeed, they are all +represented by nothing at all! The code generator ``knows'' to generate no +code, and allocate no registers etc, for primitive states. +@ +type State# s +@ + +The type @GHCbuiltins.RealWorld@ is truly opaque: there are no values defined +of this type, and no operations over it. It is ``primitive'' in that +sense---but it is {\em not unboxed!} Its only role in life is to be the type +which distinguishes the @PrimIO@ state transformer (see +Section~\ref{sect:io-spec}). +@ +data RealWorld +@ + +\subsubsection{States} + +A single, primitive, value of type @State# RealWorld@ is provided. +@ +realWorld# :: State# GHCbuiltins.RealWorld +@ +(Note: in the compiler, not a @PrimOp@; just a mucho magic @Id@.) + +\subsection{State pairing types} +\label{sect:horrid-pairing-types} + +This subsection defines some types which, while they aren't quite primitive +because we can define them in Haskell, are very nearly so. They define +constructors which pair a primitive state with a value of each primitive type. +They are required to express the result type of the primitive operations in the +state monad. +@ +data StateAndPtr# s elt = StateAndPtr# (State# s) elt + +data StateAndChar# s = StateAndChar# (State# s) Char# +data StateAndInt# s = StateAndInt# (State# s) Int# +data StateAndWord# s = StateAndWord# (State# s) Word# +data StateAndFloat# s = StateAndFloat# (State# s) Float# +data StateAndDouble# s = StateAndDouble# (State# s) Double# +data StateAndAddr# s = StateAndAddr# (State# s) Addr# + +data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a) +data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj# +data StateAndSynchVar# s a = StateAndSynchVar# (State# s) (SynchVar# a) + +data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt) +data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt) +data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray# +data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s) +@ + + +\subsection{Mutable arrays} +\label{sect:mutable} + +Corresponding to @Array#@ and @ByteArray#@, +we have the types of mutable versions of each. +In each case, the representation is a pointer +to a suitable block of (mutable) heap-allocated storage. +@ +type MutableArray# s elt +type MutableByteArray# s +@ +\subsubsection{Allocation.} + +Mutable arrays can be allocated. +Only pointer-arrays are initialised; arrays of non-pointers are filled +in by ``user code'' rather than by the array-allocation primitive. +Reason: only the pointer case has to worry about GC striking with a +partly-initialised array. +@ +newArray# :: Int# -> elt -> State# s -> StateAndMutableArray# s elt + +newCharArray# :: Int# -> State# s -> StateAndMutableByteArray# s +newIntArray# :: Int# -> State# s -> StateAndMutableByteArray# s +newAddrArray# :: Int# -> State# s -> StateAndMutableByteArray# s +newFloatArray# :: Int# -> State# s -> StateAndMutableByteArray# s +newDoubleArray# :: Int# -> State# s -> StateAndMutableByteArray# s +@ +The size of a @ByteArray#@ is given in bytes. + +\subsubsection{Reading and writing} + +%OLD: Remember, offsets in a @MutableByteArray#@ are in bytes. +@ +readArray# :: MutableArray# s elt -> Int# -> State# s -> StateAndPtr# s elt +readCharArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndChar# s +readIntArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndInt# s +readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndAddr# s +readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndFloat# s +readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndDouble# s + +writeArray# :: MutableArray# s elt -> Int# -> elt -> State# s -> State# s +writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s +writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s +writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s +writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s +@ + +\subsubsection{Equality.} + +One can take ``equality'' of mutable arrays. What is compared is the +{\em name} or reference to the mutable array, not its contents. +@ +sameMutableArray# :: MutableArray# s elt -> MutableArray# s elt -> Bool +sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool +@ + +\subsubsection{Freezing mutable arrays} + +Only unsafe-freeze has a primitive. (Safe freeze is done directly in Haskell +by copying the array and then using @unsafeFreeze@.) +@ +unsafeFreezeArray# :: MutableArray# s elt -> State# s -> StateAndArray# s elt +unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> StateAndByteArray# s +@ + +\subsubsection{Stable pointers} + +{\em Andy's comment.} {\bf Errors:} The following is not strictly true: the current +implementation is not as polymorphic as claimed. The reason for this +is that the C programmer will have to use a different entry-routine +for each type of stable pointer. At present, we only supply a very +limited number (1) of these routines. It might be possible to +increase the range of these routines by providing general purpose +entry points to apply stable pointers to (stable pointers to) +arguments and to enter (stable pointers to) boxed primitive values. +{\em End of Andy's comment.} + +A stable pointer is a name for a Haskell object which can be passed to the +external world. It is ``stable'' in the sense that the name does not change when +the Haskell garbage collector runs --- in contrast to the address of the object +which may well change. + +The stable pointer type is parameterised by the type of the thing which is named. +@ +type StablePtr# a +@ +A stable pointer is represented by an index into the (static) +@StablePointerTable@. The Haskell garbage collector treats the +@StablePointerTable@ as a source of roots for GC. + +The @makeStablePointer@ function converts a value into a stable pointer. +It is part of the @PrimIO@ monad, because we want to be sure we don't +allocate one twice by accident, and then only free one of the copies. +@ +makeStablePointer# :: a -> State# RealWorld -> StateAndStablePtr# RealWorld a +freeStablePointer# :: StablePtr# a -> State# RealWorld -> State# RealWorld +deRefStablePointer# :: StablePtr# a -> State# RealWorld -> StateAndPtr RealWorld a +@ +There is also a C procedure @FreeStablePtr@ which frees a stable pointer. + +% +% Rewritten and updated for MallocPtr++ -- 4/96 SOF +% +\subsubsection{Foreign objects} + +A @ForeignObj@ is a reference to an object outside the Haskell +world (i.e., from the C world, or a reference to an object on another +machine completely.), where the Haskell world has been told ``Let me +know when you're finished with this ...''. + +The @ForeignObj@ type is just a special @Addr#@ ({\em not} parameterised). +@ +type ForeignObj# +@ + +A typical use of @ForeignObj@ is in constructing Haskell bindings +to external libraries. A good example is that of writing a binding to +an image-processing library (which was actually the main motivation +for implementing @ForeignObj@'s precursor, @MallocPtr@). The +images manipulated are not stored in the Haskell heap, either because +the library insist on allocating them internally or we (sensibly) +decide to spare the GC from having to heave heavy images around. + +@ +data Image = Image ForeignObj# + +instance CCallable Image +@ + +The @ForeignObj#@ type is then used to refer to the externally +allocated image, and to acheive some type safety, the Haskell binding +defines the @Image@ data type. So, a value of type @ForeignObj#@ is +used to ``box'' up an external reference into a Haskell heap object +that we can then indirectly reference: + +@ +createImage :: (Int,Int) -> PrimIO Image +@ + +So far, this looks just like an @Addr#@ type, but @ForeignObj#@ +offers a bit more, namely that we can specify a {\em finalisation +routine} to invoke when the @ForeignObj#@ is discarded by the +GC. The garbage collector invokes the finalisation routine associated +with the @ForeignObj#@, saying `` Thanks, I'm through with this +now..'' For the image-processing library, the finalisation routine could for +the images free up memory allocated for them. The finalisation routine has +currently to be written in C (the finalisation routine can in turn call on +@FreeStablePtr@ to deallocate a stable pointer.). + +Associating a finalisation routine with an external object is done by +@makeForeignObj#@: + +@ +makeForeignObj# :: Addr# -- foreign reference + -> Addr# -- pointer to finalisation routine + -> StateAndForeignObj# RealWorld ForeignObj# +@ + +(Implementation: a linked list of all @ForeignObj#@s is maintained to allow the + garbage collector to detect when a @ForeignObj#@ becomes garbage.) + +Like @Array@, @ForeignObj#@s are represented by heap objects. + +{\bf ToDo:} Decide whether @FreeCHeapPointer@ is allowed to call on a +stable pointer. (I sincerely hope not since we will still be in the +GC at this point.) + +\subsubsection{Synchronizing variables (I-vars, M-vars)} + +ToDo ToDo ToDo + +@ +type SynchVar# s elt -- primitive + +newSynchVar#:: State# s -> StateAndSynchVar# s elt + +takeMVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt +putMVar# :: SynchVar# s elt -> State# s -> State# s + +readIVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt +writeIVar# :: SynchVar# s elt -> State# s -> State# s +@ + +\subsubsection{Controlling the garbage collector} + +The C function {\tt PerformGC\/}, allows the C world to force Haskell +to do a garbage collection. It can only be called while Haskell +is performing a C Call. + +Note that this function can be used to define a Haskell IO operation +with the same effect: +@ +> performGCIO :: PrimIO () +> performGCIO = _ccall_gc_ PerformGC +@ + +{\bf ToDo:} Is there any need for abnormal/normal termination to force +a GC too? Is there any need for a function that provides finer +control over GC: argument = amount of space required; result = amount +of space recovered. + +\subsection{@spark#@ primitive operation (for parallel execution)} + +{\em ToDo: say something} It's used in the unfolding for @par@. + +\subsection{The @errorIO#@ primitive operation} + +The @errorIO#@ primitive takes an argument much like @PrimIO@. It aborts execution of +the current program, and continues instead by performing the given @PrimIO@-like value +on the current state of the world. +@ +errorIO# :: (State RealWorld -> ((), State RealWorld)) -> a +@ + +\subsection{C Calls} + +{\bf ToDo:} current implementation has state variable as second +argument not last argument. + +The @ccall#@ primitive can't be given an ordinary type, because it has +a variable number of arguments. The nearest we can get is: +@ +ccall# :: CRoutine -> a1# -> ... -> an# -> State# RealWorld -> StateAndR# RealWorld +@ +where the type variables @a1#@\ldots@an#@ and @r#@ can be instantiated by any +primitive type, and @StateAndR#@ is the appropriate pairing type from +Section~\ref{sect:horrid-pairing-types}. The @CRoutine@ +isn't a proper Haskell type at all; it just reminds us that @ccall#@ needs to +know what C routine to call. + +This notation is really short for a massive family of @ccall#@ primitives, one +for each combination of types. (Of course, the compiler simply remembers the +types involved, and generates appropriate code when it finally spits out the C.) + +Unlike all the other primitive operators, @ccall#@ is not bound to an in-scope +identifier. The only way it is possible to generate a @ccall#@ is via the +@_ccall_@ construct. + +All this applies equally to @casm#@: +@ +casm# :: CAsmString -> a1# -> ... -> an# -> State# RealWorld -> StateAndR# RealWorld +@ + +%------------------------------------------------------------ +\section{Library stuff built with the Really Primitive Stuff} + +\subsection{The state transformer monad} + +\subsubsection{Types} + +A state transformer is a function from a state to a pair of a result and a new +state. +@ +newtype ST s a = ST (State s -> (a, State s)) +@ +The @ST@ type is {\em abstract}, so that the programmer cannot see its +representation. If he could, he could write bad things like: +@ +bad :: ST s a +bad = ST $ \ s -> ...(f s)...(g s)... +@ +Here, @s@ is duplicated, which would be bad news. + +A state is represented by a primitive state value, of type @State# s@, +wrapped up in a @State@ constructor. The reason for boxing it in this +way is so that we can be strict or lazy in the state. (Remember, all +primitive types are unboxed, and hence can't be bottom; but types built +with @data@ are all boxed.) +@ +data State s = S# (State# s) +@ + +\subsubsection{The state transformer combinators} + +Now for the combinators, all of which live inside the @ST@ +abstraction. Notice that @returnST@ and @thenST@ are lazy in the +state. +@ +returnST :: a -> ST s a +returnST a s = (a, s) + +thenST :: ST s a -> (a -> ST s b) -> ST s b +thenST m k s = let (r,new_s) = m s + in + k r new_s + +fixST :: (a -> ST s a) -> ST s a +fixST k s = let ans = k r s + (r,new_s) = ans + in + ans +@ +The interesting one is, of course, @runST@. We can't infer its type! +(It has a funny name because it must be wired into the compiler.) +@ +-- runST :: forall a. (forall s. ST s a) -> a +runST m = case m (S# realWorld#) of + (r,_) -> r +@ + +\subsubsection{Other useful combinators} + +There are various other standard combinators, all defined in terms the +fundamental combinators above. The @seqST@ combinator is like +@thenST@, except that it discards the result of the first state +transformer: +@ +seqST :: ST s a -> ST s b -> ST s b +seqST m1 m2 = m1 `thenST` (\_ -> m2) +@ + +We also have {\em strict} (... in the state...) variants of the +then/return combinators (same types as their pals): +@ +returnStrictlyST a s@(S# _) = (a, s) + +thenStrictlyST m k s@(S# _) + = case (m s) of { (r, new_s@(S# _)) -> + k r new_s } + +seqStrictlyST m k = ... ditto, for seqST ... +@ + +The combinator @listST@ takes a list of state transformers, and +composes them in sequence, returning a list of their results: +@ +listST :: [ST s a] -> ST s [a] +listST [] = returnST [] +listST (m:ms) = m `thenST` \ r -> + listST ms `thenST` \ rs -> + returnST (r:rs) +@ +The @mapST@ combinator ``lifts'' a function from a value to state +transformers to one which works over a list of values: +@ +mapST :: (a -> ST s b) -> [a] -> ST s [b] +mapST f ms = listST (map f ms) +@ +The @mapAndUnzipST@ combinator is similar to @mapST@, except that here the +function returns a pair: +@ +mapAndUnzipST :: (a -> ST s (b,c)) -> [a] -> ST s ([b],[c]) +mapAndUnzipST f (m:ms) + = f m `thenST` \ ( r1, r2) -> + mapAndUnzipST f ms `thenST` \ (rs1, rs2) -> + returnST (r1:rs1, r2:rs2) +@ + +\subsubsection{The @PrimIO@ monad} +\label{sect:io-spec} + +The @PrimIO@ type is defined in as a state transformer which manipulates the +@RealWorld@. +@ +type PrimIO a = ST RealWorld a -- Transparent +@ +The @PrimIO@ type is an ordinary type synonym, transparent to the programmer. + +The type @RealWorld@ and value @realWorld#@ do not need to be hidden (although +there is no particular point in exposing them). Even having a value of type +@realWorld#@ does not compromise safety, since the type @ST@ is hidden. + +It is type-correct to use @returnST@ in an I/O context, but it is a +bit more efficient to use @returnPrimIO@. The latter is strict in the +state, which propagates backwards to all the earlier combinators +(provided they are unfolded). Why is it safe for @returnPrimIO@ to be +strict in the state? Because every context in which an I/O state +transformer is used will certainly evaluate the resulting state; it is +the state of the real world! +@ +returnPrimIO :: a -> PrimIO a +returnPrimIO a s@(S# _) -> (a, s) +@ +We provide strict versions of the other combinators too. +@ +thenPrimIO m k s = case m s of + (r,s) -> k r s +@ +@fixPrimIO@ has to be lazy, though! +@ +fixPrimIO = fixST +@ +The other combinators are just the same as before, but use the strict +@thenPrimIO@ and @returnPrimIO@ for efficiency. +@ +foldrPrimIO f z [] = z +foldrPrimIO f z (m:ms) = foldrPrimIO f z ms `thenPrimIO` \ ms' -> + f m ms' + +listPrimIO ms = foldrPrimIO (\ a xs -> a `thenPrimIO` \ x -> returnPrimIO (x : xs)) + (returnPrimIO []) ms + +mapPrimIO f ms = listPrimIO (map f ms) + +mapAndUnzipPrimIO f (m:ms) + = f m `thenPrimIO` \ ( r1, r2) -> + mapAndUnzipPrimIO f ms `thenPrimIO` \ (rs1, rs2) -> + returnPrimIO (r1:rs1, r2:rs2) +@ + +\subsection{Arrays} + +\subsubsection{Types} + +@ +data Array ix elt = Array (ix,ix) (Array# elt) +data ByteArray ix = ByteArray (ix,ix) ByteArray# + +data MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt) +data MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s) +@ + +\subsubsection{Operations on immutable arrays} + +Ordinary array indexing is straightforward. +@ +(!) :: Ix ix => Array ix elt -> ix -> elt +@ +QUESTIONs: should @ByteArray@s be indexed by Ints or ix? With byte offsets +or sized ones? (sized ones [WDP]) +@ +indexCharArray :: Ix ix => ByteArray ix -> ix -> Char +indexIntArray :: Ix ix => ByteArray ix -> ix -> Int +indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr +indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float +indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double +@ +@Addr@s are indexed straightforwardly by @Int@s. Unlike the primitive +operations, though, the offsets assume that the array consists entirely of the +type of value being indexed, and so there's an implicit multiplication by +the size of that value. To access @Addr@s with mixed values requires +you to do a DIY job using the primitives. +@ +indexAddrChar :: Addr -> Int -> Char +...etc... +indexStaticCharArray :: Addr -> Int -> Char +indexStaticIntArray :: Addr -> Int -> Int +indexStaticFloatArray :: Addr -> Int -> Float +indexStaticDoubleArray :: Addr -> Int -> Double +indexStaticArray :: Addr -> Int -> Addr +@ + +\subsubsection{Operations on mutable arrays} +@ +newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) +newCharArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) +... +@ + +@ +readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt +readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char +... +@ + +@ +writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () +writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () +... +@ + +@ +freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) +freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +... +@ + +We have no need on one-function-per-type for unsafe freezing: +@ +unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) +unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +@ + +Sometimes we want to snaffle the bounds of one of these beasts: +@ +boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix) +boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix) +@ + +Lastly, ``equality'': +@ +sameMutableArray :: MutableArray s ix elt -> MutableArray s ix elt -> Bool +sameMutableByteArray :: MutableByteArray s ix -> MutableByteArray s ix -> Bool +@ + + +\subsection{Variables} + +\subsubsection{Types} + +Mutable variables are (for now anyway) implemented as arrays. The @MutableVar@ type +is opaque, so we can change the implementation later if we want. +@ +type MutableVar s a = MutableArray s Int a +@ + +\subsubsection{Operations} +@ +newVar :: a -> ST s (MutableVar s a) +readVar :: MutableVar s a -> ST s a +writeVar :: MutableVar s a -> a -> ST s () +sameVar :: MutableVar s a -> MutableVar s a -> Bool +@ + +\subsection{Stable pointers} + +Nothing exciting here, just simple boxing up. +@ +data StablePtr a = StablePtr (StablePtr# a) + +makeStablePointer :: a -> StablePtr a +freeStablePointer :: StablePtr a -> PrimIO () +@ + +\subsection{Foreign objects} + +Again, just boxing up. +@ +data ForeignObj = ForeignObj ForeignObj# + +makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj +@ + +\subsection{C calls} + +Everything in this section goes for @_casm_@ too. + +{\em ToDo: mention @_ccall_gc_@ and @_casm_gc_@...} + +The @_ccall_@ construct has the following form: +$$@_ccall_@~croutine~a_1~\ldots~a_n$$ +This whole construct has type $@PrimIO@~res$. +The rules are these: +\begin{itemize} +\item +The first ``argument'', $croutine$, must be the literal name of a C procedure. +It cannot be a Haskell expression which evaluates to a string, etc; it must be +simply the name of the procedure. +\item +The arguments $a_1, \ldots,a_n$ must be of {\em C-callable} type. +\item +The whole construct has type $@PrimIO@~ty$, where $ty$ is a {\em C-returnable} type. +\end{itemize} +A {\em boxed-primitive} type is both C-callable and C-returnable. +A boxed primitive type is anything declared by: +@ +data T = C# t +@ +where @t@ is a primitive type. Note that +programmer-defined boxed-primitive types are perfectly OK: +@ +data Widget = W# Int# +data Screen = S# CHeapPtr# +@ + +There are other types that can be passed to C (C-callable). This +table summarises (including the standard boxed-primitive types): +@ +Boxed Type of transferd Corresp. Which is +Type Prim. component C type *probably*... +------ --------------- ------ ------------- +Char Char# StgChar unsigned char +Int Int# StgInt long int +Word Word# StgWord unsigned long int +Addr Addr# StgAddr char * +Float Float# StgFloat float +Double Double# StgDouble double + +Array Array# StgArray StgPtr +ByteArray ByteArray# StgByteArray StgPtr +MutableArray MutableArray# StgArray StgPtr +MutableByteArray MutableByteArray# StgByteArray StgPtr + +State State# nothing! + +StablePtr StablePtr# StgStablePtr StgPtr +ForeignObj ForeignObj# StgForeignObj StgPtr +@ + +All of the above are {\em C-returnable} except: +@ + Array, ByteArray, MutableArray, MutableByteArray +@ + +{\bf ToDo:} I'm pretty wary of @Array@ and @MutableArray@ being in +this list, and not too happy about @State@ [WDP]. + +{\bf ToDo:} Can code generator pass all the primitive types? Should this be +extended to include {\tt Bool\/} (or any enumeration type?) + +The type checker must be able to figure out just which of the C-callable/returnable +types is being used. If it can't, you have to add type signatures. For example, +@ +f x = _ccall_ foo x +@ +is not good enough, because the compiler can't work out what type @x@ is, nor +what type the @_ccall_@ returns. You have to write, say: +@ +f :: Int -> PrimIO Float +f x = _ccall_ foo x +@ + +\subsubsection{Implementation} + +The desugarer unwraps the @_ccall_@ construct by inserting the necessary +evaluations etc to unbox the arguments. For example, the body of the definition +of @f@ above would become: +@ + (\ s -> case x of { I# x# -> + case s of { S# s# -> + case ccall# [Int#,Float#] x# s# of { StateAndFloat# f# new_s# -> + (F# f#, S# new_s#) + }}}) +@ +Notice that the state, too, is unboxed. + +The code generator must deal specially with primitive objects which +are stored on the heap. + +... details omitted ... + +% +%More importantly, it must construct a C Heap Pointer heap-object after +%a @_ccall_@ which returns a @MallocPtr#@. +% + +%-------------------------------------------------------- +\section{Non-primitive stuff that must be wired into GHC} + +@ +data Char = C# Char# +data Int = I# Int# +data Word = W# Word# +data Addr = A# Addr# + +data Float = F# Float# +data Double = D# Double# +data Integer = J# Int# Int# ByteArray# + +-- and the other boxed-primitive types: + Array, ByteArray, MutableArray, MutableByteArray, + StablePtr, ForeignObj + +data Bool = False | True +data Ordering = LT | EQ | GT -- used in derived comparisons + +data List a = [] | a : (List a) +-- tuples... + +data Lift a = Lift a -- used Yukkily as described elsewhere + +type String = [Char] -- convenience, only +@ + +%------------------------------------------------------------ +\section{Programmer interface(s)} + +\subsection{The bog-standard interface} + +If you rely on the implicit @import Prelude@ that GHC normally does +for you, and if you don't use any weird flags (notably +@-fglasgow-exts@), and if you don't import one of the fairly-magic +@PreludeGla*@ interfaces, then GHC should work {\em exactly} as the +Haskell report says, and the full user namespaces should be available +to you. + +\subsection{If you mess about with @import Prelude@...} + +Innocent hiding, e.g., +@ +import Prelude hiding ( fromIntegral ) +@ +should work just fine. + +There are some things you can do that will make GHC crash, e.g., +hiding a standard class: +@ +import Prelude hiding ( Eq(..) ) +@ +Don't do that. + +\subsection{Turning on Glasgow extensions with @-fglasgow-exts@} + +If you turn on @-fglasgow-exts@, then all the primitive types and +operations described herein are available. + +It is possible that some name conflicts between your code and the +wired-in things might spring to life (though we doubt it...). +Change your names :-) + +\end{document} + diff --git a/ghc/docs/release_notes/real-soon-now.lit b/ghc/docs/users_guide/real-soon-now.lit index 7fd5b85b67..7fd5b85b67 100644 --- a/ghc/docs/release_notes/real-soon-now.lit +++ b/ghc/docs/users_guide/real-soon-now.lit diff --git a/ghc/docs/users_guide/recomp.lit b/ghc/docs/users_guide/recomp.lit index f9da199194..90a64ebe34 100644 --- a/ghc/docs/users_guide/recomp.lit +++ b/ghc/docs/users_guide/recomp.lit @@ -7,8 +7,8 @@ %************************************************************************ The Haskell~1.3 module system (nicely improved, thank you very much) -requires a substantially different implementation, which we have done -for GHC~2.01. +requires a substantially different implementation, which we did +(as of release GHC~2.01). We have taken a fairly radical approach and implemented a ``go to the horse's mouth'' scheme; that is, when seeking out information about an @@ -31,11 +31,11 @@ GHC will now start ``compiling'' much more often than in the old days, but it will frequently bail out quickly, saying the recompile is \tr{NOT NEEDED}. What a beautiful sight! -The recompilation checker is not finished. Its main faults are: -(a)~it doesn't yet do the right things for instance declarations; -(b)~it doesn't do anything about pragmas (happily, GHC~2.01 doesn't -produce any); (c)~it has no good solution for mutually-recursive -modules. +%The recompilation checker is not finished. Its main faults are: +%(a)~it doesn't yet do the right things for instance declarations; +%(b)~it doesn't do anything about pragmas (happily, GHC~2.01 doesn't +%produce any); (c)~it has no good solution for mutually-recursive +%modules. Patrick Sansom has a workshop paper about how all these things should be done. Ask him (email: \tr{sansom}) if you want a copy. diff --git a/ghc/docs/release_notes/release.lit b/ghc/docs/users_guide/release.lit index 49e92f1c39..49e92f1c39 100644 --- a/ghc/docs/release_notes/release.lit +++ b/ghc/docs/users_guide/release.lit diff --git a/ghc/docs/users_guide/user.lit b/ghc/docs/users_guide/user.lit index bf3a3613f3..8144e8205e 100644 --- a/ghc/docs/users_guide/user.lit +++ b/ghc/docs/users_guide/user.lit @@ -1,7 +1,7 @@ \begin{onlystandalone} \documentstyle[11pt,literate]{article} \begin{document} -\title{The Glorious Glasgow Haskell Compilation System\\ Version~2.01\\ User's Guide} +\title{The Glorious Glasgow Haskell Compilation System\\ Version~2.02\\ User's Guide} \author{The GHC Team\\ Department of Computing Science\\ University of Glasgow\\ @@ -17,6 +17,7 @@ Email: glasgow-haskell-\{bugs,users\}-request\@dcs.gla.ac.uk} \end{onlystandalone} \input{intro.lit} +\input{release.lit} \input{how_to_run.lit} \input{runtime_control.lit} \input{sooner.lit} diff --git a/ghc/driver/Makefile b/ghc/driver/Makefile index 330608071f..d2e0077d02 100644 --- a/ghc/driver/Makefile +++ b/ghc/driver/Makefile @@ -1,10 +1,16 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.2 1996/11/21 16:47:27 simonm Exp $ +# $Id: Makefile,v 1.3 1997/03/14 07:59:40 simonpj Exp $ -TOP=../.. +TOP=.. CURRENT_DIR=ghc/driver -UnlitSuffixRules = YES -include $(TOP)/ghc/mk/ghc.mk +include $(TOP)/mk/boilerplate.mk + +# +# The ways setup doesn't apply to the driver +# +WAYS= + +INSTALLING=0 DYN_LOADABLE_BITS = \ ghc-asm.prl \ @@ -13,22 +19,140 @@ DYN_LOADABLE_BITS = \ ghc-consist.prl \ ghc-split.prl -PROG = ghc -SRC = ghc.prl +SCRIPT_PROG = ghc +SCRIPT_OBJS = ghc.prl + INTERP = $(PERL) -DESTDIR = $(INSTBINDIR_GHC) -INSTALLED_NAME = $(GHC_DRIVER_INST_NAME) + +# +# The driver needs to know the options and names for +# all possible ways, so we magically generate the +# the make variable names for them here. +# + +WAY_NAMES = $(foreach way,$(ALL_WAYS),WAY_$(way)_NAME) +WAY_OPTS = $(foreach way,$(ALL_WAYS),WAY_$(way)_HC_OPTS) + +ifeq "$(INSTALLING)" "1" +TOP_PWD := $(prefix) +else +TOP_PWD := $(FPTOOLS_TOP_ABS) +endif + +SCRIPT_SUBST_VARS := \ + INSTALLING \ + PROJECTNAME PROJECTVERSION PROJECTPATCHLEVEL \ + CURRENT_DIR TMPDIR HOSTPLATFORM TARGETPLATFORM \ + GHC_LIB_DIR GHC_RUNTIME_DIR GHC_UTILS_DIR GHC_INCLUDE_DIR \ + GHC_OPT_HILEV_ASM GhcWithNativeCodeGen LeadingUnderscore\ + GHC_UNLIT GHC_HSCPP GHC_HSC GHC_SYSMAN \ + CP RM PERL CONTEXT_DIFF \ + $(WAY_NAMES) $(WAY_OPTS) + +# +# When creating a binary distribution, we prefix the driver script +# with a short msg about what variables need to be set to get the +# script going. +# + +ifeq "$(BIN_DIST)" "1" +SCRIPT_PREFIX_FILES=prefix.txt +else +SCRIPT_SUBST_VARS += TOP_PWD INSTLIBDIR_GHC INSTDATADIR_GHC PERL +endif all :: $(DYN_LOADABLE_BITS) -install :: $(DYN_LOADABLE_BITS) - $(INSTALL) $(INSTDATAFLAGS) $(DYN_LOADABLE_BITS) $(INSTLIBDIR_GHC) +# +# Install setup: +# the driver goes in $(bindir), the perl script helpers +# in $(libdir) +# +# ToDo: allow different install name for driver? +# +INSTALL_PROGS += $(SCRIPT_PROG) +INSTALL_LIBS += $(DYN_LOADABLE_BITS) + +# +# Before really installing the driver, we have to +# reconfigure it such that the paths it refers to, +# point to the installed utils. +# +install :: + @$(RM) $(SCRIPT_PROG) + @$(MAKE) $(MFLAGS) INSTALLING=1 $(SCRIPT_PROG) + +# +# depend setup: other directories need the driver script to compute +# their dependencies, so `depend' is simply an alias for `all' here. +depend :: all + +# +# Clean up +# +CLEAN_FILES += $(SCRIPT_OBJS) $(DYN_LOADABLE_BITS) + +# +# Source distribution +# +SRC_DEST_FILES=$(patsubst %.prl,%.lprl,$(DYN_LOADABLE_BITS)) ghc.lprl ordering-passes test_mangler + +include $(TOP)/mk/target.mk + +# Hack to re-create the in-situ build tree driver script after +# having installed it. +# +install :: + @$(RM) $(SCRIPT_PROG) + @$(MAKE) $(MFLAGS) BIN_DIST=0 $(SCRIPT_PROG) + + +# +# Option vars for the special ways +# + +# Way p: +WAY_p_NAME=profiling +WAY_p_HC_OPTS+=-fscc-profiling -DPROFILING -optc-DPROFILING + +# Way t: +WAY_t_NAME+=ticky-ticky profiling +WAY_t_HC_OPTS=-fticky-ticky -DTICKY_TICKY -optc-DTICKY_TICKY + +# Way `u': +WAY_u_NAME=unregisterized (using portable C only) +WAY_u_HC_OPTS= + +# Way `mc': concurrent +WAY_mc_NAME=concurrent +WAY_mc_HC_OPTS+=-fstack-check -fconcurrent -D__CONCURRENT_HASKELL__ -DCONCURRENT -optcpp-D__CONCURRENT_HASKELL__ -optcpp-DCONCURRENT + +# Way `mr': +WAY_mr_NAME=profiled concurrent +WAY_mr_HC_OPTS+=-fstack-check -fconcurrent -fscc-profiling -D__CONCURRENT_HASKELL__ -DCONCURRENT -DPROFILING -optcpp-D__CONCURRENT_HASKELL__ -optcpp-DCONCURRENT -optcpp-DPROFILING + +# Way `mt': +WAY_mt_NAME=ticky-ticky concurrent +WAY_mt_HC_OPTS+=-fstack-check -fconcurrent -fticky-ticky -D__CONCURRENT_HASKELL__ -DCONCURRENT -DTICKY-TICKY -optc-D__CONCURRENT_HASKELL__ -optc-DCONCURRENT -optc-DTICKY_TICKY + +# Way `mp': +WAY_mp_NAME=parallel +WAY_mp_HC_OPTS+=-fstack-check -fconcurrent -D__PARALLEL_HASKELL__ -DPAR -optcpp-D__PARALLEL_HASKELL__ -optc-DPAR -optc-DCONCURRENT + +# +# Way `mg': +# Q: is passing -D__GRANSIM__ and -DGRAN to hscpp needed? +WAY_mg_NAME=GranSim +WAY_mg_HC_OPTS+=-fstack-check -fconcurrent -fgransim -D__GRANSIM__ -DGRAN -optcpp-D__GRANSIM__ -optc-DGRAN -optc-D__CONCURRENT_HASKELL__ -optc-DCONCURRENT -clean:: - $(RM) ghc.prl - $(RM) $(DYN_LOADABLE_BITS) +# +# Ways for different garbage collectors +# +WAY_2s_NAME=2-space GC +WAY_2s_HC_OPTS+=-optc-DGC2s -# DYN_LOADABLE_LPRLS = $(DYN_LOADABLE_BITS:.prl=.lprl) -# PerlTagsTarget( ghc.lprl $(DYN_LOADABLE_LPRLS) ) +WAY_1s_NAME=1-space GC +WAY_1s_HC_OPTS+=-optc-DGC1s -include $(TOP)/mk/script.mk +WAY_du_NAME=dual-mode GC +WAY_du_HC_OPTS+=-optc-DGCdu diff --git a/ghc/driver/ghc-consist.lprl b/ghc/driver/ghc-consist.lprl index 22abeca6ac..59d220ebbc 100644 --- a/ghc/driver/ghc-consist.lprl +++ b/ghc/driver/ghc-consist.lprl @@ -38,7 +38,7 @@ sub chk_consistency_info { print STDERR "$Pgm: consistency warning: minor version not $HsC_minor_version:\n$_\n" if $minor_version != $HsC_minor_version; $Status++, - print STDERR "$Pgm: consistency error: not options $HsC_consist_options:\n$_\n" + print STDERR "$Pgm: consistency error: not options $opts -- $HsC_consist_options:\n$_\n" if $opts ne $HsC_consist_options; } else { # phase is cc ... diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl index 533d529089..5f606fb5af 100644 --- a/ghc/driver/ghc-iface.lprl +++ b/ghc/driver/ghc-iface.lprl @@ -171,7 +171,7 @@ sub readHiFile { next if /\{-# GHC_PRAGMA INTERFACE VERSION 20 #-\}/; # avoid pre-1.3 interfaces -#print STDERR "now_in:$now_in:$_"; + #print STDERR "now_in:$now_in:$_"; if ( /\{-# GHC_PRAGMA INTERFACE VERSION . #-\}/ ) { $HiExists{$mod} = 0; last hi_line; @@ -208,7 +208,7 @@ sub readHiFile { $_ = $2; } - if ( /^(\S+)\s+::\s+/ ) { + if ( /^(\S+)\s+_:_\s+/ ) { $current_name = $1; $Decl{"$mod:$current_name"} = $_; if ($mod eq "old") { $OldVersion{$current_name} = $version; } @@ -238,6 +238,8 @@ sub readHiFile { $Decl{"$mod:$current_name"} .= $_ } + } elsif ( /^--.*/ ) { # silently ignore comment lines. + ; } else { print STDERR "$Pgm:junk old iface line?:section:$now_in:$_"; } diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 8629c83cba..8294675cd6 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -1,8 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -% *** MSUB does some substitutions here *** -% *** grep for $( *** +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997 % This is the driver script for the Glasgow Haskell compilation system. @@ -65,18 +62,24 @@ Other commonly-used options are: -H14m Increase compiler's heap size + -M Output the Makefile rules recording the + dependencies of a list of Haskell files. + (ghc driver just calls upon the help of a + compatible mkdependHS script to do the + actual processing) + The User's Guide has more information about GHC's *many* options. Given the above, here are some TYPICAL invocations of $Pgm: # compile a Haskell module to a .o file, optimising: % $Pgm -c -O Foo.hs + # link three .o files into an executable called "test": + % $Pgm -o test Foo.o Bar.o Baz.o # compile a Haskell module to C (a .hc file), using a bigger heap: % $Pgm -C -H16m Foo.hs # compile Haskell-produced C (.hc) to assembly language: % $Pgm -S Foo.hc - # link three .o files into an executable called "test": - % $Pgm -o test Foo.o Bar.o Baz.o ------------------------------------------------------------------------ EOUSAGE \end{code} @@ -87,15 +90,44 @@ EOUSAGE %* * %************************************************************************ -Establish what executables to run for the various phases (all the -\tr{$(FOO)} make-variables are \tr{msub}bed for from the -\tr{Makefile}), what the default options are for those phases, and -other similar boring stuff. +The driver script need to be told where to find these executables, so +in the course of building the driver `executable', make-variables holding +these are prepended to the de-litted version of this file. The variables are: + +\begin{verbatim} +INSTALLING + +HOSTPLATFORM TARGETPLATFORM + +PROJECTNAME PROJECTVERSION PROJECTPATCHLEVEL + +TOP_PWD + +INSTLIBDIR_GHC INSTDATADIR_GHC + +CURRENT_DIR TMPDIR + +GHC_LIB_DIR GHC_RUNTIME_DIR GHC_UTILS_DIR GHC_INCLUDE_DIR + +GHC_OPT_HILEV_ASM GhcWithNativeCodeGen + +GHC_UNLIT GHC_HSCPP GHC_HSC GHC_SYSMAN + +CP RM PERL CONTEXT_DIFF + +WAY_*_NAME WAY_*_HC_OPTS + +LeadingUnderscore + +\end{verbatim} + +Establish what executables to run for the various phases, what the +default options are for those phases, and other similar boring stuff. + \begin{code} select(STDERR); $| = 1; select(STDOUT); # no STDERR buffering, please. -$HostPlatform = '$(HOSTPLATFORM)'; -$TargetPlatform = '$(TARGETPLATFORM)'; +$TargetPlatform = $TARGETPLATFORM; #------------------------------------------------------------------------ # If you are adjusting paths by hand for a binary GHC distribution, @@ -105,28 +137,28 @@ $TargetPlatform = '$(TARGETPLATFORM)'; # $ENV{'GLASGOW_HASKELL_ROOT'} = '/some/absolute/path/name'; if (! $ENV{'GLASGOW_HASKELL_ROOT'}) { # good -- death to environment variables - $TopPwd = '$(TOP_PWD)'; - $InstLibDirGhc = '$(INSTLIBDIR_GHC)'; - $InstDataDirGhc = '$(INSTDATADIR_GHC)'; + $TopPwd = ${TOP_PWD}; + $InstLibDirGhc = ${INSTLIBDIR_GHC}; + $InstDataDirGhc = ${INSTDATADIR_GHC}; } else { $TopPwd = $ENV{'GLASGOW_HASKELL_ROOT'}; - if ('$(INSTLIBDIR_GHC)' =~ /.*(\/lib\/ghc\/\d\.\d\d\/[^-]-[^-]-[^-]\/.*)/) { + if (${INSTLIBDIR_GHC} =~ /.*(\/lib\/ghc\/\d\.\d\d\/[^-]+-[^-]+-[^-]+\/.*)/) { $InstLibDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $1; } else { - print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $(INSTLIBDIR_GHC).\n(Installation error)\n"; + print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $INSTLIBDIR_GHC.\n(Installation error)\n"; exit(1); } - if ('$(INSTDATADIR_GHC)' =~ /.*(\/lib\/ghc\/\d\.\d\d\/.*)/) { + if (${INSTDATADIR_GHC} =~ /.*(\/lib\/ghc\/\d\.\d\d\/.*)/) { $InstDataDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $2; } else { - print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $(INSTDATADIR_GHC).\n(Installation error)\n"; + print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $INSTDATADIR_GHC.\n(Installation error)\n"; exit(1); } } -if ( $(INSTALLING) ) { +if ( $INSTALLING ) { $InstSysLibDir = $InstDataDirGhc; $InstSysLibDir =~ s/\/ghc\//\/hslibs\//; } else { @@ -143,70 +175,57 @@ $SIG{'QUIT'} = 'quit_upon_signal'; # where to get "require"d .prl files at runtime (poor man's dynamic loading) # (use LIB, not DATA, because we can't be sure of arch-independence) -@INC = ( ( $(INSTALLING) ) ? $InstLibDirGhc - : "$TopPwd/$(CURRENT_DIR)" ); +@INC = ( ( $INSTALLING ) ? $InstLibDirGhc + : "$TopPwd/${CURRENT_DIR}" ); if ( $ENV{'TMPDIR'} ) { # where to make tmp file names $Tmp_prefix = ($ENV{'TMPDIR'} . "/ghc$$"); } else { - $Tmp_prefix ="$(TMPDIR)/ghc$$"; - $ENV{'TMPDIR'} = '$(TMPDIR)'; # set the env var as well + print STDERR "TMPDIR has not been set to anything useful!\n" if (${TMPDIR} eq ''); + $Tmp_prefix ="${TMPDIR}/ghc$$"; # TMPDIR set via Makefile when booting.. + $ENV{'TMPDIR'} = ${TMPDIR}; # set the env var as well } @Files_to_tidy = (); # files we nuke in the case of abnormal termination -$Unlit = ( $(INSTALLING) ) ? "$InstLibDirGhc/unlit" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_UNLIT)"; +$Unlit = ( $INSTALLING ) ? "$InstLibDirGhc/unlit" + : "$TopPwd/${CURRENT_DIR}/${GHC_UNLIT}"; -$Cp = '$(CP)'; -$Rm = '$(RM)'; -$Diff = '$(CONTEXT_DIFF)'; +$Cp = $CP; +$Rm = $RM; +$Diff = $CONTEXT_DIFF; $Cat = 'cat'; $Cmp = 'cmp'; $Time = ''; $HsCpp = # but this is re-set to "cat" (after options) if -cpp not seen - ( $(INSTALLING) ) ? "$InstLibDirGhc/hscpp" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_HSCPP)"; + ( $INSTALLING ) ? "$InstLibDirGhc/hscpp" + : "$TopPwd/${CURRENT_DIR}/${GHC_HSCPP}"; @HsCpp_flags = (); $genSPECS_flag = ''; # See ../utils/hscpp/hscpp.prl -$HsC = ( $(INSTALLING) ) ? "$InstLibDirGhc/hsc" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_HSC)"; +$HsC = ( $INSTALLING ) ? "$InstLibDirGhc/hsc" + : "$TopPwd/${CURRENT_DIR}/${GHC_HSC}"; # For PVM fiends only -$SysMan = ( $(INSTALLING) ) ? "$InstLibDirGhc/SysMan" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_SYSMAN)"; - +$SysMan = ( $INSTALLING ) ? "$InstLibDirGhc/SysMan" + : "$TopPwd/${CURRENT_DIR}/${GHC_SYSMAN}"; @Unlit_flags = (); +# # HsC_rts_flags: if we want to talk to the LML runtime system # NB: we don't use powers-of-2 sizes, because this may do # terrible things to cache behavior. +# $Specific_heap_size = 6 * 1000 * 1000; $Specific_stk_size = 1000 * 1000; $Scale_sizes_by = 1.0; -@HsC_rts_flags = (); - -@HsP_flags = (); # these are the flags destined solely for - # the flex/yacc parser -@HsC_flags = (); -@HsC_antiflags = (); -\end{code} -The optimisations/etc to be done by the compiler are {\em normally} -expressed with a \tr{-O} (or \tr{-O2}) flag, or by its absence. - -\begin{code} -$OptLevel = 0; # no -O == 0; -O == 1; -O2 == 2; -Ofile == 3 -$MinusO2ForC = 0; # set to 1 if -O2 should be given to C compiler -$StolenX86Regs = 4; # **HACK*** of the very worst sort -$CoreLint = ''; \end{code} -These variables represent parts of the -O/-O2/etc ``templates,'' -which are filled in later, using these. +The variables set by @setupOptFlags@ represent parts of the +-O/-O2/etc ``templates,'' which are filled in later, using these. These are the default values, which may be changed by user flags. \begin{code} @@ -225,16 +244,21 @@ sub setupOptFlags { $Oopt_FoldrBuildInline = ''; # was '-fdo-inline-foldr-build'; } # end of setupOptFlags +# Assign defaults to these right away. &setupOptFlags(); \end{code} Things to do with C compilers/etc: \begin{code} -$CcRegd = '$(GHC_OPT_HILEV_ASM)'; +$CcRegd = $GHC_OPT_HILEV_ASM; @CcBoth_flags = ('-S'); # flags for *any* C compilation @CcInjects = (); -# GCC flags: those for all files, those only for .c files; those only for .hc files +# GCC flags: +# those for all files, +# those only for .c files; +# those only for .hc files + @CcRegd_flags = ('-ansi', '-D__STG_GCC_REGS__', '-D__STG_TAILJUMPS__'); @CcRegd_flags_c = (); @CcRegd_flags_hc = (); @@ -256,201 +280,187 @@ Prelude ({\em including} its interface file(s)). \begin{code} $BuildTag = ''; # default is sequential build w/ Appel-style GC -%BuildAvail = ('', '$(Build_normal)', - '_p', '$(Build_p)', - '_t', '$(Build_t)', - '_u', '$(Build_u)', - '_mc', '$(Build_mc)', - '_mr', '$(Build_mr)', - '_mt', '$(Build_mt)', - '_mp', '$(Build_mp)', - '_mg', '$(Build_mg)', - '_2s', '$(Build_2s)', - '_1s', '$(Build_1s)', - '_du', '$(Build_du)', - '_a', '$(Build_a)', - '_b', '$(Build_b)', - '_c', '$(Build_c)', - '_d', '$(Build_d)', - '_e', '$(Build_e)', - '_f', '$(Build_f)', - '_g', '$(Build_g)', - '_h', '$(Build_h)', - '_i', '$(Build_i)', - '_j', '$(Build_j)', - '_k', '$(Build_k)', - '_l', '$(Build_l)', - '_m', '$(Build_m)', - '_n', '$(Build_n)', - '_o', '$(Build_o)', - '_A', '$(Build_A)', - '_B', '$(Build_B)' ); - -%BuildDescr = ('', 'normal sequential', - '_p', 'profiling', - '_t', 'ticky-ticky profiling', -#OLD: '_u', 'unregisterized (using portable C only)', - '_mc', 'concurrent', - '_mr', 'profiled concurrent', - '_mt', 'ticky concurrent', - '_mp', 'parallel', - '_mg', 'GranSim', - '_2s', '2-space GC', - '_1s', '1-space GC', - '_du', 'dual-mode GC', - '_a', 'user way a', - '_b', 'user way b', - '_c', 'user way c', - '_d', 'user way d', - '_e', 'user way e', - '_f', 'user way f', - '_g', 'user way g', - '_h', 'user way h', - '_i', 'user way i', - '_j', 'user way j', - '_k', 'user way k', - '_l', 'user way l', - '_m', 'user way m', - '_n', 'user way n', - '_o', 'user way o', - '_A', 'user way A', - '_B', 'user way B' ); +%BuildDescr = (# system ways begin + '', 'normal sequential', + '_p', "$WAY_p_NAME", + '_t', "$WAY_t_NAME", + '_u', "$WAY_u_NAME", + '_mc', "$WAY_mc_NAME", + '_mr', "$WAY_mr_NAME", + '_mt', "$WAY_mt_NAME", + '_mp', "$WAY_mp_NAME", + '_mg', "$WAY_mg_NAME", + '_2s', "$WAY_2s_NAME", + '_1s', "$WAY_1s_NAME", + '_du', "$WAY_du_NAME", + # system ways end + '_a', "$WAY_a_NAME", + '_b', "$WAY_b_NAME", + '_c', "$WAY_c_NAME", + '_d', "$WAY_d_NAME", + '_e', "$WAY_e_NAME", + '_f', "$WAY_f_NAME", + '_g', "$WAY_g_NAME", + '_h', "$WAY_h_NAME", + '_i', "$WAY_i_NAME", + '_j', "$WAY_j_NAME", + '_k', "$WAY_k_NAME", + '_l', "$WAY_l_NAME", + '_m', "$WAY_m_NAME", + '_n', "$WAY_n_NAME", + '_o', "$WAY_o_NAME", + '_A', "$WAY_A_NAME", + '_B', "$WAY_B_NAME" ); # these are options that are "fed back" through the option processing loop -%UserSetupOpts = ('_a', '$(GHC_BUILD_OPTS_a)', - '_b', '$(GHC_BUILD_OPTS_b)', - '_c', '$(GHC_BUILD_OPTS_c)', - '_d', '$(GHC_BUILD_OPTS_d)', - '_e', '$(GHC_BUILD_OPTS_e)', - '_f', '$(GHC_BUILD_OPTS_f)', - '_g', '$(GHC_BUILD_OPTS_g)', - '_h', '$(GHC_BUILD_OPTS_h)', - '_i', '$(GHC_BUILD_OPTS_i)', - '_j', '$(GHC_BUILD_OPTS_j)', - '_k', '$(GHC_BUILD_OPTS_k)', - '_l', '$(GHC_BUILD_OPTS_l)', - '_m', '$(GHC_BUILD_OPTS_m)', - '_n', '$(GHC_BUILD_OPTS_n)', - '_o', '$(GHC_BUILD_OPTS_o)', - '_A', '$(GHC_BUILD_OPTS_A)', - '_B', '$(GHC_BUILD_OPTS_B)', - - # the GC ones don't have any "fed back" options - '_2s', '', - '_1s', '', - '_du', '' ); +# +%SetupOpts = + ( + '_a', "$WAY_a_HC_OPTS", + '_b', "$WAY_b_HC_OPTS", + '_c', "$WAY_c_HC_OPTS", + '_d', "$WAY_d_HC_OPTS", + '_e', "$WAY_e_HC_OPTS", + '_f', "$WAY_f_HC_OPTS", + '_g', "$WAY_g_HC_OPTS", + '_h', "$WAY_h_HC_OPTS", + '_i', "$WAY_i_HC_OPTS", + '_j', "$WAY_j_HC_OPTS", + '_k', "$WAY_k_HC_OPTS", + '_l', "$WAY_l_HC_OPTS", + '_m', "$WAY_m_HC_OPTS", + '_n', "$WAY_n_HC_OPTS", + '_o', "$WAY_o_HC_OPTS", + '_A', "$WAY_A_HC_OPTS", + '_B', "$WAY_B_HC_OPTS", + + # system ways + '_p', "$WAY_p_HC_OPTS", + '_t', "$WAY_t_HC_OPTS", + '_u', "$WAY_u_HC_OPTS", + '_mc', "$WAY_mc_HC_OPTS", + '_mr', "$WAY_mr_HC_OPTS", + '_mt', "$WAY_mt_HC_OPTS", + '_mp', "$WAY_mp_HC_OPTS", + '_mg', "$WAY_mg_HC_OPTS", + '_2s', "$WAY_2s_HC_OPTS", + '_1s', "$WAY_1s_HC_OPTS", + '_du', "$WAY_B_HC_OPTS" ); # per-build code fragments which are eval'd -%EvaldSetupOpts = ('', '', # this one must *not* be set! - - # profiled sequential - '_p', 'push(@HsC_flags, \'-fscc-profiling\'); - push(@CcBoth_flags, \'-DPROFILING\');', - - #and maybe ... - #push(@CcBoth_flags, '-DPROFILING_DETAIL_COUNTS'); - - # ticky-ticky sequential - '_t', 'push(@HsC_flags, \'-fticky-ticky\'); - push(@CcBoth_flags, \'-DTICKY_TICKY\');', - -#OLD: # unregisterized (ToDo????) -# '_u', '', - - # concurrent - '_mc', '$StkChkByPageFaultOK = 0; - push(@HsC_flags, \'-fconcurrent\'); - push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\'); - push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\');', - - # profiled concurrent - '_mr', '$StkChkByPageFaultOK = 0; - push(@HsC_flags, \'-fconcurrent\', \'-fscc-profiling\'); - push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\'); - push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPROFILING\');', - - # ticky-ticky concurrent - '_mt', '$StkChkByPageFaultOK = 0; - push(@HsC_flags, \'-fconcurrent\', \'-fticky-ticky\'); - push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\'); - push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DTICKY_TICKY\');', - - # parallel - '_mp', '$StkChkByPageFaultOK = 0; - push(@HsC_flags, \'-fconcurrent\'); - push(@HsCpp_flags,\'-D__PARALLEL_HASKELL__\', \'-DPAR\'); - push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPAR\');', - - # GranSim - '_mg', '$StkChkByPageFaultOK = 0; - push(@HsC_flags, \'-fconcurrent\', \'-fgransim\'); - push(@HsCpp_flags,\'-D__GRANSIM__\', \'-DGRAN\'); - push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DGRAN\');', - - '_2s', 'push (@CcBoth_flags, \'-DGC2s\');', - '_1s', 'push (@CcBoth_flags, \'-DGC1s\');', - '_du', 'push (@CcBoth_flags, \'-DGCdu\');', - - '_a', '', # these user-way guys should not be set! - '_b', '', - '_c', '', - '_d', '', - '_e', '', - '_f', '', - '_g', '', - '_h', '', - '_i', '', - '_j', '', - '_k', '', - '_l', '', - '_m', '', - '_n', '', - '_o', '', - '_A', '', - '_B', '' ); +#%EvaldSetupOpts = ('', '', # this one must *not* be set! + +# # profiled sequential +# '_p', 'push(@HsC_flags, \'-fscc-profiling\'); +# push(@CcBoth_flags, \'-DPROFILING\');', + +# #and maybe ... +# #push(@CcBoth_flags, '-DPROFILING_DETAIL_COUNTS'); + +# # ticky-ticky sequential +# '_t', 'push(@HsC_flags, \'-fticky-ticky\'); +# push(@CcBoth_flags, \'-DTICKY_TICKY\');', + +##OLD: # unregisterized (ToDo????) +## '_u', '', + +# # concurrent +# '_mc', '$StkChkByPageFaultOK = 0; +# push(@HsC_flags, \'-fconcurrent\'); +# push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\'); +# push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\');', + +# # profiled concurrent +# '_mr', '$StkChkByPageFaultOK = 0; +# push(@HsC_flags, \'-fconcurrent\', \'-fscc-profiling\'); +# push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\'); +# push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPROFILING\');', + +# # ticky-ticky concurrent +# '_mt', '$StkChkByPageFaultOK = 0; +# push(@HsC_flags, \'-fconcurrent\', \'-fticky-ticky\'); +# push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\'); +# push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DTICKY_TICKY\');', + +# # parallel +# '_mp', '$StkChkByPageFaultOK = 0; +# push(@HsC_flags, \'-fconcurrent\'); +# push(@HsCpp_flags,\'-D__PARALLEL_HASKELL__\', \'-DPAR\'); +# push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPAR\');', + +# # GranSim +# '_mg', '$StkChkByPageFaultOK = 0; +# push(@HsC_flags, \'-fconcurrent\', \'-fgransim\'); +# push(@HsCpp_flags,\'-D__GRANSIM__\', \'-DGRAN\'); +# push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DGRAN\');', + +# '_2s', 'push (@CcBoth_flags, \'-DGC2s\');', +# '_1s', 'push (@CcBoth_flags, \'-DGC1s\');', +# '_du', 'push (@CcBoth_flags, \'-DGCdu\');', + +# '_a', '', # these user-way guys should not be set! +# '_b', '', +# '_c', '', +# '_d', '', +# '_e', '', +# '_f', '', +# '_g', '', +# '_h', '', +# '_i', '', +# '_j', '', +# '_k', '', +# '_l', '', +# '_m', '', +# '_n', '', +# '_o', '', +# '_A', '', +# '_B', '' ); + \end{code} Import/include directories (\tr{-I} options) are sufficiently weird to require special handling. + \begin{code} @Import_dir = ('.'); #-i things @Include_dir = ('.'); #-I things; other default(s) stuck on AFTER option processing -@SysImport_dir = ( $(INSTALLING) ) +# where to look for interface files (system hi's, i.e., prelude and hslibs) +@SysImport_dir = ( $INSTALLING ) ? ( "$InstDataDirGhc/imports" ) - : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/ghc" - , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/glaExts" - , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/required" - , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/concurrent" ); + : ( "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/required" + , "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/ghc" + , "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/glaExts" + , "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/concurrent" ); # We need to look in ghc/ and glaExts/ when searching for implicitly needed .hi files, but # we should really *not* look there for explicitly imported modules. -$GhcVersionInfo = int ($(PROJECTVERSION) * 100); -$Haskell1Version = 3; # i.e., Haskell 1.3 +$GhcVersionInfo = int ($PROJECTVERSION * 100); +$Haskell1Version = 4; # i.e., Haskell 1.4 @Cpp_define = (); @UserLibrary_dir= (); #-L things;... @UserLibrary = (); #-l things asked for by the user -@SysLibrary_dir = ( ( $(INSTALLING) ) #-syslib things supplied by the system +@SysLibrary_dir = ( ( $INSTALLING ) #-syslib things supplied by the system ? $InstLibDirGhc - : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_RUNTIMESRC)" - , "$TopPwd/$(CURRENT_DIR)/$(GHC_RUNTIMESRC)/gmp" - , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)" - , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/cbits" + : ( "$TopPwd/$CURRENT_DIR/$GHC_RUNTIME_DIR" + , "$TopPwd/$CURRENT_DIR/$GHC_RUNTIME_DIR/gmp" + , "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR" + , "$TopPwd/$CURRENT_DIR/$GHC_LIB_DIR/cbits" ) ); @SysLibrary = (); # will be built up as we go along $TopClosureFile # defaults to 1.2 one; will be mangled later - = ( $(INSTALLING) ) ? "$InstLibDirGhc/TopClosureXXXX.o" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_RUNTIMESRC)/main/TopClosureXXXX.o"; + = ( $INSTALLING) ? "$InstLibDirGhc/TopClosureXXXX.o" + : "$TopPwd/$CURRENT_DIR/$GHC_RUNTIME_DIR/main/TopClosureXXXX.o"; # make depend for Haskell $MkDependHS - = ( $(INSTALLING) ) ? "$InstLibDirGhc/mkdependHS" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_UTILSRC)/mkdependHS/mkdependHS"; + = ( $INSTALLING ) ? "$InstLibDirGhc/mkdependHS" + : "$TopPwd/$CURRENT_DIR/$GHC_UTILS_DIR/mkdependHS/mkdependHS"; # Fill in later @MkDependHS_flags = ( ); @@ -473,14 +483,17 @@ sub initDriverGlobals { # the flex/yacc parser @HsC_flags = (); @HsC_antiflags = (); +\end{code} +The optimisations/etc to be done by the compiler are {\em normally} +expressed with a \tr{-O} (or \tr{-O2}) flag, or by its absence. + +\begin{code} $OptLevel = 0; # no -O == 0; -O == 1; -O2 == 2; -Ofile == 3 $MinusO2ForC = 0; # set to 1 if -O2 should be given to C compiler $StolenX86Regs = 4; # **HACK*** of the very worst sort $CoreLint = ''; - -# reset flags used to guide the meaning of -O<level> -&setupOptFlags(); +$StgLint = ''; @CcBoth_flags = ('-S'); # flags for *any* C compilation @CcInjects = (); @@ -511,10 +524,10 @@ $Only_generate_deps = 0; # $PostprocessCcOutput = 0; # native code-gen or via C? -$HaveNativeCodeGen = $(GhcWithNativeCodeGen); +$HaveNativeCodeGen = $GhcWithNativeCodeGen; $HscOut = '-C='; # '-C=' ==> .hc output; '-S=' ==> .s output; '-N=' ==> neither $HscOut = '-S=' - if $HaveNativeCodeGen && $TargetPlatform =~ /^(alpha|sparc)-/; #ToDo: add |i386 ! + if $HaveNativeCodeGen && $TargetPlatform =~ /^(i386|alpha|sparc)-/; $ProduceHi = '-hifile='; $HiOnStdout = 0; $HiDiff_flag = ''; @@ -539,6 +552,7 @@ $Using_dump_file = 0; $Isuffix = ''; $Osuffix = ''; # default: use the normal suffix for that kind of output $HiSuffix = 'hi'; +$HiSuffix_prelude = ''; $Do_recomp_chkr = 0; # don't use the recompilatio checker unless asked $Do_cc = -1; # a MAGIC indeterminate value; will be set to 1 or 0. $Do_as = 1; @@ -581,9 +595,9 @@ $LinkChk = 1; # set to 0 if the link check should *not* be done # major & minor version numbers; major numbers must always agree; # minor disagreements yield a warning. -$HsC_major_version = 30; +$HsC_major_version = 31; $HsC_minor_version = 0; -$Cc_major_version = 35; +$Cc_major_version = 36; $Cc_minor_version = 0; # options: these must always agree @@ -674,32 +688,6 @@ if ($Specific_output_dir ne '' && $Specific_output_file ne '') { } } -# PROFILING stuff after argv mangling: -if ( ! $PROFing ) { - # warn about any scc exprs found (in case scc used as identifier) - push(@HsP_flags, '-W'); - - # add -auto sccs even if not profiling ! - push(@HsC_flags, $UNPROFscc_auto) if $UNPROFscc_auto; - -} else { - push(@HsC_flags, $PROFauto) if $PROFauto; - push(@HsC_flags, $PROFcaf) if $PROFcaf; - #push(@HsC_flags, $PROFdict) if $PROFdict; - - $Oopt_FinalStgProfilingMassage = '-fmassage-stg-for-profiling'; - - push(@HsP_flags, (($PROFignore_scc) ? $PROFignore_scc : '-S')); - - if ( $SplitObjFiles ) { - # can't split with cost centres -- would need global and externs - print STDERR "$Pgm: WARNING: splitting objects when profiling will *BREAK* if any _scc_s are present!\n"; - # (but it's fine if there aren't any _scc_s around...) -# $SplitObjFiles = 0; # unset - #not an error: for now: $Status++; - } -} - # crash and burn if there were errors if ( $Status > 0 ) { print STDERR $ShortUsage; @@ -1023,18 +1011,44 @@ Sort out @$BuildTag@, @$PROFing@, @$CONCURing@, @$PARing@, \begin{code} sub setupBuildFlags { - if ( $BuildTag ne '' ) { - local($b) = $BuildDescr{$BuildTag}; - if ($CONCURing eq 'c') { print STDERR "$Pgm: Can't mix $b with -concurrent.\n"; exit 1; } - if ($PARing eq 'p') { print STDERR "$Pgm: Can't mix $b with -parallel.\n"; exit 1; } - if ($GRANing eq 'g') { print STDERR "$Pgm: Can't mix $b with -gransim.\n"; exit 1; } - if ($TICKYing eq 't') { print STDERR "$Pgm: Can't mix $b with -ticky.\n"; exit 1; } - # ok to have a user-way profiling build - # eval the profiling opts ... but leave user-way BuildTag - if ($PROFing eq 'p') { eval($EvaldSetupOpts{'_p'}); } + # PROFILING stuff after argv mangling: + if ( ! $PROFing ) { + # warn about any scc exprs found (in case scc used as identifier) + push(@HsP_flags, '-W'); + + # add -auto sccs even if not profiling ! + push(@HsC_flags, $UNPROFscc_auto) if $UNPROFscc_auto; + + } else { + push(@HsC_flags, $PROFauto) if $PROFauto; + push(@HsC_flags, $PROFcaf) if $PROFcaf; + #push(@HsC_flags, $PROFdict) if $PROFdict; + + $Oopt_FinalStgProfilingMassage = '-fmassage-stg-for-profiling'; - } elsif ( $PROFing eq 'p' ) { + push(@HsP_flags, (($PROFignore_scc) ? $PROFignore_scc : '-S')); + + if ( $SplitObjFiles ) { + # can't split with cost centres -- would need global and externs + print STDERR "$Pgm: WARNING: splitting objects when profiling will *BREAK* if any _scc_s are present!\n"; + # (but it's fine if there aren't any _scc_s around...) +# $SplitObjFiles = 0; # unset + #not an error: for now: $Status++; + } + } + #if ( $BuildTag ne '' ) { + # local($b) = $BuildDescr{$BuildTag}; + # if ($CONCURing eq 'c') { print STDERR "$Pgm: Can't mix $b with -concurrent.\n"; exit 1; } + # if ($PARing eq 'p') { print STDERR "$Pgm: Can't mix $b with -parallel.\n"; exit 1; } + # if ($GRANing eq 'g') { print STDERR "$Pgm: Can't mix $b with -gransim.\n"; exit 1; } + # if ($TICKYing eq 't') { print STDERR "$Pgm: Can't mix $b with -ticky.\n"; exit 1; } + + # # ok to have a user-way profiling build + # # eval the profiling opts ... but leave user-way BuildTag + # if ($PROFing eq 'p') { &processArgs(split(' ', $SetupOpts{'_p'})); } # eval($EvaldSetupOpts{'_p'}); } + + if ( $PROFing eq 'p' ) { if ($PARing eq 'p') { print STDERR "$Pgm: Can't do profiling with -parallel.\n"; exit 1; } if ($GRANing eq 'g') { print STDERR "$Pgm: Can't do profiling with -gransim.\n"; exit 1; } if ($TICKYing eq 't') { print STDERR "$Pgm: Can't do profiling with -ticky.\n"; exit 1; } @@ -1071,21 +1085,33 @@ After the sanity checks, add flags to the necessary parts of the driver pipeline \begin{code} if ( $BuildTag ne '' ) { # something other than normal sequential... - local($Tag) = $BuildTag; + local($Tag) = "${BuildTag}"; $Tag =~ s/_//; # move the underscore to the back - push(@HsP_flags, "-hisuf=.${Tag}_hi"); # use appropriate Prelude .hi files $HscOut = '-C='; # must go via C - - eval($EvaldSetupOpts{$BuildTag}); + &processArgs(split(' ', $SetupOpts{$BuildTag})); +# eval($EvaldSetupOpts{$BuildTag}); } \end{code} Decide what the consistency-checking options are in force for this run: \begin{code} + $HsC_consist_options = "${BuildTag},${DEBUGging}"; $Cc_consist_options = "${BuildTag},${DEBUGging}"; + # + # Funny place to put it, but why not. + # + if ( $HiSuffix_prelude eq '' ) { + local($Tag) = "${BuildTag}"; + $Tag =~ s/_//; + $Tag = "${Tag}_" if $Tag ne ''; + $HiSuffix_prelude="${Tag}hi"; + } + push(@HsC_flags, "-hisuf-prelude=.${HiSuffix_prelude}"); # use appropriate Prelude .hi files + push(@HsC_flags, "-hisuf=.${HiSuffix}"); + } # setupBuildFlags \end{code} @@ -1114,10 +1140,14 @@ sub setupMachOpts { # we know how to *mangle* asm for hppa unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); unshift(@CcBoth_flags, ('-static')); + # # We don't put in '-mlong-calls', because it's only # needed for very big modules (sigh), and we don't want # to hobble ourselves further on all the other modules # (most of them). + # + # [Dated comment (gcc-2.6.x?), -mlong-calls is no longer + # a supported gcc HPPA flag] unshift(@CcBoth_flags, ('-D_HPUX_SOURCE')); # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! # (very nice, but too bad the HP /usr/include files don't agree.) @@ -1181,31 +1211,27 @@ sub setupMachOpts { Same unshifting magic, but for special linker flags. -Should really be whether or not we prepend underscores to global symbols, -not an architecture test. (JSM) +The configure script determines whether the object file symbol tables +have a leading underscore, and sets @LeadingUnderscore@ accordingly. +(The driver script `sees' the setting of the @LeadingUnderscore@ +by having the Makefile prepend it). \begin{code} sub setupLinkOpts { - $Under = ( $TargetPlatform =~ /^alpha-/ - || $TargetPlatform =~ /^hppa/ - || $TargetPlatform =~ /^mips-sgi-irix/ - || $TargetPlatform =~ /^powerpc-/ - || $TargetPlatform =~ /-solaris/ - || $TargetPlatform =~ /-linux$/ - ) - ? '' : '_'; + local($uscore) = ( ${LeadingUnderscore} eq 'YES' ) ? '_' : ''; unshift(@Ld_flags, (($Ld_main) ? ( - '-u', "${Under}Main_" . $Ld_main . '_closure', + '-u', "${uscore}Main_" . $Ld_main . '_closure', ) : () -# , '-u', "${Under}STbase_unsafePerformPrimIO_fast1" -# , '-u', "${Under}Prelude_Z91Z93_closure" # i.e., [] -# , '-u', "${Under}Prelude_IZh_static_info" -# , '-u', "${Under}Prelude_False_inregs_info" -# , '-u', "${Under}Prelude_True_inregs_info" -# , '-u', "${Under}Prelude_CZh_static_info" -# , '-u', "${Under}DEBUG_REGS" +# What are these? -- SOF +# , '-u', "${uscore}STbase_unsafePerformPrimIO_fast1" +# , '-u', "${uscore}Prelude_Z91Z93_closure" # i.e., [] +# , '-u', "${uscore}Prelude_IZh_static_info" +# , '-u', "${uscore}Prelude_False_inregs_info" +# , '-u', "${uscore}Prelude_True_inregs_info" +# , '-u', "${uscore}Prelude_CZh_static_info" +# , '-u', "${uscore}DEBUG_REGS" )) ; # just for fun, now... @@ -1226,8 +1252,8 @@ Ready for Business. \begin{code} sub setupIncPaths { # default includes must be added AFTER option processing - if ( ! $(INSTALLING) ) { - push (@Include_dir, "$TopPwd/$(CURRENT_DIR)/$(GHC_INCLUDESRC)"); + if ( ! $INSTALLING ) { + push (@Include_dir, "$TopPwd/${CURRENT_DIR}/${GHC_INCLUDE_DIR}"); } else { push (@Include_dir, "$InstLibDirGhc/includes"); push (@Include_dir, "$InstDataDirGhc/includes"); @@ -1251,7 +1277,12 @@ sub setupSyslibs { # Push library HSrts, plus boring clib bit push(@SysLibrary, "-lHSrts${BuildTag}"); push(@SysLibrary, '-lHSclib'); - push(@SysLibrary, '-lwinmm') if $BuildTag ne ''; # cygwin32 specific + # + # RTS compiled with cygwin32, uses the WinMM API + # to implement the itimers, since cygwin.dll does not + # support it. Only reqd. for `ways' that use itimers. + # + push(@SysLibrary, '-lwinmm') if $BuildTag ne '' && $TargetPlatform eq 'i386-unknown-cygwin32'; # Push the pvm libraries if ($BuildTag eq '_mp') { @@ -1278,9 +1309,9 @@ push(@SysLibrary, '-lm'); Before continuing we check that the appropriate build is available. \begin{code} -die "$Pgm: no BuildAvail?? $BuildTag\n" if ! $BuildAvail{$BuildTag}; # sanity +#die "$Pgm: no BuildAvail?? $BuildTag\n" if $BuildDescr{$BuildTag} eq '' ; # sanity -if ( $BuildAvail{$BuildTag} =~ /^NO$/ ) { +if ( $BuildDescr{$BuildTag} eq '' ) { print STDERR "$Pgm: a `", $BuildDescr{$BuildTag}, "' \"build\" is not available with your GHC setup.\n"; print STDERR "(It was not configured for it at your site.)\n"; @@ -1326,7 +1357,7 @@ if ($#Input_file < 0 && $#Link_file < 0) { Tell the world who we are, if they asked. \begin{code} -print STDERR "$(PROJECTNAME), version $(PROJECTVERSION) $(PROJECTPATCHLEVEL)\n" +print STDERR "${PROJECTNAME}, version ${PROJECTVERSION} ${PROJECTPATCHLEVEL}\n" if $Verbose; \end{code} @@ -1349,7 +1380,8 @@ if ( $Status > 0 ) { # don't link if there were errors... exit $Status; } -# append last minute flags linker flags (entry point) +# append last minute flags linker and consistency flags +&setupBuildFlags(); &setupSyslibs(); &setupLinkOpts(); @@ -1412,10 +1444,10 @@ if ($Do_lnkr) { # OK, now create the magic script for "$executable" open(EXEC, "> $executable") || &tidy_up_and_die(1,"$Pgm: couldn't open $executable to write!\n"); print EXEC <<EOSCRIPT1; -#!$(PERL) +#!${PERL} # =!=!=!=!=!=!=!=!=!=!=! # This script is automatically generated: DO NOT EDIT!!! -# Generated by Glasgow Haskell, version $(PROJECTVERSION) $(PROJECTPATCHLEVEL) +# Generated by Glasgow Haskell, version ${PROJECTVERSION} ${PROJECTPATCHLEVEL} # \$pvm_executable = '$pvm_executable'; \$pvm_executable_base = '$pvm_executable_base'; @@ -1523,17 +1555,12 @@ Again, we'll do the post-recompilation-checker parts of this later. local($do_lit2pgm) = ($ifile =~ /\.lhs$/) ? 1 : 0; local($do_hscpp) = 1; # but "hscpp" might really be "cat" local($do_hsc) = 1; - local($do_cc) = ( $Do_cc != -1) # i.e., it was set explicitly - ? $Do_cc - : ( ($HscOut eq '-C=') ? 1 : 0 ); - local($do_as) = $Do_as; # names of the files to stuff between phases # defaults are temporaries local($in_lit2pgm) = $ifile; local($lit2pgm_hscpp) = "$Tmp_prefix.lpp"; local($hscpp_hsc) = "$Tmp_prefix.cpp"; - local($hsc_out) = ( $HscOut eq '-C=' ) ? "$Tmp_prefix.hc" : "$Tmp_prefix.s" ; local($hsc_hi) = "$Tmp_prefix.hi"; local($cc_as_o) = "${Tmp_prefix}_o.s"; # temporary for raw .s file if opt C local($cc_as) = "$Tmp_prefix.s"; # mangled or hsc-produced .s code @@ -1541,54 +1568,68 @@ Again, we'll do the post-recompilation-checker parts of this later. local($is_hc_file) = 1; #Is the C code .hc or .c? Assume .hc for now - if ($ifile =~ /\.lhs$/) { - ; # nothing to change - } elsif ($ifile =~ /\.hs$/) { - $do_lit2pgm = 0; - $lit2pgm_hscpp = $ifile; - } elsif ($ifile =~ /\.hc$/ || $ifile =~ /_hc$/ ) { # || $ifile =~ /\.$Isuffix$/o) # ToDo: better - $do_lit2pgm = 0; $do_hscpp = 0; $do_hsc = 0; $do_cc = 1; - $hsc_out = $ifile; - } elsif ($ifile =~ /\.c$/) { - $do_lit2pgm = 0; $do_hscpp = 0; $do_hsc = 0; $do_cc = 1; - $hsc_out = $ifile; $is_hc_file = 0; - } elsif ($ifile =~ /\.s$/) { - $do_lit2pgm = 0; $do_hscpp = 0; $do_hsc = 0; $do_cc = 0; - $cc_as = $ifile; - } else { # don't know what it is, but nothing to do herein... - $do_lit2pgm = 0; $do_hscpp = 0; $do_hsc = 0; $do_cc = 0; $do_as = 0; - } + $lit2pgm_hscpp = $ifile if ($ifile =~ /\.hs$/); # OK, let's strip off some literate junk: - &runLit2pgm($in_lit2pgm, $lit2pgm_hscpp) - if $do_lit2pgm; + &runLit2pgm($in_lit2pgm, $lit2pgm_hscpp) if ($ifile =~ /\.lhs$/); # @File_options = (); # Scan the top of the de-litted file for {-# OPTIONS #-} pragmas - &check_for_source_options($lit2pgm_hscpp,*File_options); - - # options found in the source file take a back seat, we will scan + &check_for_source_options($lit2pgm_hscpp); + # options found in the source file take a back seat, i.e., we scan # them first. Only process the command line again if source file # contained anything of interest *or* there's more than one # input file (we have to reset the options). # - if ( $#Input_file > 1 || $#File_options > 0) { + if ( $#Input_file >= 0 || $#File_options >= 0) { @File_options = (@File_options, @Cmd_opts); # Now process the command line + &initDriverGlobals(); &processArgs(@File_options); } # # Having got the effective command line scanned, set up # the various options in prep for some real work. # - &setupOptimiseFlags(); + # check the sanity of the BuildTag we're about to use, + # and if needs be, add some more flags and setup to + # the different phases. + # &setupBuildFlags(); + &setupOptimiseFlags(); &setupMachOpts(); &setupIncPaths(); &setupHeapStackSize(); + # + # These two variables need to be set after the + # command-line has been processed and the build options + # have be seen set up. This is because command-line options + # can control whether to compile vias C or not. + # + local($do_cc) = ( $Do_cc != -1) # i.e., it was set explicitly + ? $Do_cc + : ( ($HscOut eq '-C=') ? 1 : 0 ); + local($do_as) = $Do_as; + local($hsc_out) = ( $HscOut eq '-C=' ) ? "$Tmp_prefix.hc" : "$Tmp_prefix.s" ; + + if ($ifile =~ /.lhs$/ || $ifile =~ /.hs$/ ) { + ; + } elsif ($ifile =~ /\.hc$/ || $ifile =~ /_hc$/ ) { # || $ifile =~ /\.$Isuffix$/o) # ToDo: better + $do_hscpp = 0; $do_hsc = 0; $do_cc = 1; + $hsc_out = $ifile; + } elsif ($ifile =~ /\.c$/) { + $do_hscpp = 0; $do_hsc = 0; $do_cc = 1; + $hsc_out = $ifile; $is_hc_file = 0; + } elsif ($ifile =~ /\.s$/) { + $do_hscpp = 0; $do_hsc = 0; $do_cc = 0; + $cc_as = $ifile; + } else { # don't know what it is, but nothing to do herein... + $do_hscpp = 0; $do_hsc = 0; $do_cc = 0; $do_as = 0; + } + # hack to avoid running hscpp $HsCpp = $Cat if ! $Cpp_flag_set; @@ -1605,6 +1646,14 @@ phase) to @"$ifile_root.<suffix>"@. \begin{code} local($going_interactive) = $HscOut eq '-N=' || $ifile_root eq '_stdin'; + # + # Warning issued if -keep-hc-file-too is used without + # -fvia-C (or the equivalent) + # + if ( $HscOut ne '-C=' && $Keep_hc_file_too ) { + print STDERR "Warning: Native code generator to be used, -keep-hc-file-too will be ignored\n"; + } + if (! $do_cc && ! $do_as) { # stopping after hsc $hsc_out = ($Specific_output_file ne '') ? $Specific_output_file @@ -1657,7 +1706,6 @@ Finally, decide what to queue up for linker input. pop(@Link_file); push(@Link_file, $ifile); } - &initDriverGlobals(); } # end of ProcessInputFile \end{code} @@ -1704,7 +1752,7 @@ sub runHscpp { \begin{code} sub runHscAndProcessInterfaces { - local($ifile, $hscpp_hsc, $ifiel_root, $ofile_target, $hifile_target) = @_; + local($ifile, $hscpp_hsc, $ifile_root, $ofile_target, $hifile_target) = @_; # $ifile is the original input file # $hscpp_hsc post-unlit, post-cpp, etc., input file @@ -1715,14 +1763,14 @@ sub runHscAndProcessInterfaces { local($source_unchanged) = 1; # Check if the source file is up to date relative to the target; in -# that case we say "source is unchanged" and let the compiler bale out +# that case we say "source is unchanged" and let the compiler bail out # early if the import usage information allows it. ($i_dev,$i_ino,$i_mode,$i_nlink,$i_uid,$i_gid,$i_rdev,$i_size, $i_atime,$i_mtime,$i_ctime,$i_blksize,$i_blocks) = stat($ifile); if ( ! -f $ofile_target ) { - print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n"; +# print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n"; $source_unchanged = 0; } @@ -1730,7 +1778,7 @@ sub runHscAndProcessInterfaces { $o_atime,$o_mtime,$o_ctime,$o_blksize,$o_blocks) = stat(_); # stat info from -f test if ( ! -f $hifile_target ) { - print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n"; +# print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n"; $source_unchanged = 0; } @@ -1738,7 +1786,7 @@ sub runHscAndProcessInterfaces { $hi_atime,$hi_mtime,$hi_ctime,$hi_blksize,$hi_blocks) = stat(_); # stat info from -f test if ($i_mtime > $o_mtime) { - print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n"; +# print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n"; $source_unchanged = 0; } @@ -1760,12 +1808,25 @@ sub runHscAndProcessInterfaces { # Tell the C compiler and assembler not to run $do_cc = 0; $do_as = 0; - # Update dependency info - &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies"); + # Update dependency info, touch both object file and + # interface file, so that the following invariant is + # maintained: + # + # a dependent module's interface file should after recompilation + # checking be newer than the interface files of its imports. + # + # That is, if module A's interface file changes, then module B + # (which import from A) needs to be checked. + # If A's change does not affect B, which causes the compiler to bail + # out early, we still need to touch the interface file of B. The reason + # for this is that B may export A's interface. + # + &run_something("touch $ofile_target $hifile_target", + "Touch $ofile_target $hifile_target, to propagate dependencies"); } else { -# Didn't bail out early (new .hi file) so we thunder on + # Didn't bail out early (new .hi file) so we thunder on # If non-interactive, heave in the consistency info at the end # NB: pretty hackish (depends on how $output is set) @@ -1860,7 +1921,7 @@ sub runHsc { } local($to_do); - $to_do = "$HsC @HsP_flags ,$hscpp_hsc $dump @HsC_flags $CoreLint $Verbose $output +RTS @HsC_rts_flags"; + $to_do = "$HsC @HsP_flags ,$hscpp_hsc $dump @HsC_flags $CoreLint $StgLint $Verbose $output +RTS @HsC_rts_flags"; &run_something($to_do, 'Haskell compiler'); # finish business w/ nofibbish time/bytes-alloc stats @@ -1871,7 +1932,7 @@ sub runHsc { Use \tr{@Import_dir} and \tr{@SysImport_dir} to make a tmp file of (module-name, pathname) pairs, one per line, separated by a space. \begin{code} -%HiMap = (); +#%HiMap = (); $HiMapDone = 0; $HiMapFile = ''; $HiIncludeString = (); # dir1:dir2:dir3, to pass to GHC @@ -1883,7 +1944,7 @@ sub makeHiMap { local($mod, $path, $d, $e); # reset the global variables: - %HiMap = (); + #%HiMap = (); $HiMapDone = 0; $HiMapFile = ''; $HiIncludeString = (); # dir1:dir2:dir3, to pass to GHC @@ -1892,53 +1953,58 @@ sub makeHiMap { if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d"; } else { $HiIncludeString = $d; } - opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n"); - local(@entry) = readdir(DIR); - foreach $e ( @entry ) { - next unless $e =~ /\b([A-Z][A-Za-z0-9_]*)\.$HiSuffix$/o; - $mod = $1; - $path = "$d/$e"; - $path =~ s,^\./,,; - - if ( ! defined($HiMap{$mod}) ) { - $HiMap{$mod} = $path; - } else { - &already_mapped_err($mod, $HiMap{$mod}, $path); - } - } - closedir(DIR); # || &tidy_up_and_die(1,"$Pgm: error when closing directory: $d\n"); +# The compiler does the searching now +# +# opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n"); +# local(@entry) = readdir(DIR); +# foreach $e ( @entry ) { +# next unless $e =~ /\b([A-Z][A-Za-z0-9_]*)\.${HiSuffix_prelude}$/o; +# $mod = $1; +# $path = "$d/$e"; +# $path =~ s,^\./,,; +# +# if ( ! defined($HiMap{$mod}) ) { +# $HiMap{$mod} = $path; +# } else { +# &already_mapped_err($mod, $HiMap{$mod}, $path); +# } +# } +# closedir(DIR); # || &tidy_up_and_die(1,"$Pgm: error when closing directory: $d\n"); } foreach $d ( @SysImport_dir ) { if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d"; } else { $HiIncludeString = $d; } - opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n"); - local(@entry) = readdir(DIR); - foreach $e ( @entry ) { - next unless $e =~ /([A-Z][A-Za-z0-9_]*)\.$HiSuffix$/o; - next if $NoImplicitPrelude && $e =~ /Prelude\.$HiSuffix$/o; - - $mod = $1; - $path = "$d/$e"; - $path =~ s,^\./,,; - - if ( ! defined($HiMap{$mod}) ) { - $HiMap{$mod} = $path; - } elsif ( $mod ne 'Main' ) { # saves useless warnings... - &already_mapped_err($mod, $HiMap{$mod}, $path); - } - } - closedir(DIR); # || &tidy_up_and_die(1,"$Pgm: error when closing directory: $d\n"); +# opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n"); +# local(@entry) = readdir(DIR); +# foreach $e ( @entry ) { +# next unless $e =~ /([A-Z][A-Za-z0-9_]*)\.$HiSuffix$/o; +# next if $NoImplicitPrelude && $e =~ /Prelude\.$HiSuffix$/o; +# +# $mod = $1; +# $path = "$d/$e"; +# $path =~ s,^\./,,; +# +# if ( ! defined($HiMap{$mod}) ) { +# $HiMap{$mod} = $path; +# } elsif ( $mod ne 'Main' ) { # saves useless warnings... +# &already_mapped_err($mod, $HiMap{$mod}, $path); +# } +# } +# closedir(DIR); # || &tidy_up_and_die(1,"$Pgm: error when closing directory: $d\n"); } - $HiMapFile = "$Tmp_prefix.himap"; - unlink($HiMapFile); - open(HIMAP, "> $HiMapFile") || &tidy_up_and_die(1,"$Pgm: can't open $HiMapFile\n"); - foreach $d (keys %HiMap) { - print HIMAP $d, ' ', $HiMap{$d}, "\n"; - } - close(HIMAP) || &tidy_up_and_die(1,"$Pgm: error when closing $HiMapFile\n"); +# +# Not currently used: +# +# $HiMapFile = "$Tmp_prefix.himap"; +# unlink($HiMapFile); +# open(HIMAP, "> $HiMapFile") || &tidy_up_and_die(1,"$Pgm: can't open $HiMapFile\n"); +# foreach $d (keys %HiMap) { +# print HIMAP $d, ' ', $HiMap{$d}, "\n"; +# } +# close(HIMAP) || &tidy_up_and_die(1,"$Pgm: error when closing $HiMapFile\n"); $HiMapDone = 1; } @@ -2062,6 +2128,7 @@ sub runMangler { # post-process the assembler [.hc files only] &mangle_asm($cc_as_o, $cc_as); + #OLD: for sanity: #OLD: local($target) = 'oops'; #OLD: $target = '-alpha' if $TargetPlatform =~ /^alpha-/; @@ -2117,6 +2184,16 @@ sub runAs { # must assemble files $Tmp_prefix__[1 .. $NoOfSplitFiles].s + # If -odir is used, great, just pin it in front of the + # generated split file names. If it hasn't been set, we + # snatch it from the ifile_root. + # + # + + if ( $Specific_output_dir eq '' ) { + $Specific_output_dir = ${ifile_root}; + } + for ($f = 1; $f <= $NoOfSplitFiles; $f++ ) { local($split_out) = &odir_ify("${ifile_root}__${f}",'o'); local($to_do) = "$asmblr -o $split_out -c @As_flags ${Tmp_prefix}__${f}.s"; @@ -2361,21 +2438,22 @@ directly. @check_for_source_options@ looks at the top of a de-lit'ified Haskell file for any such pragmas: \begin{code} -# sub check_for_source_options { - local($file, *FileArgs) = @_; + local($file) = @_; + + open(FILE,$file) || return(1); # No big loss - open(FILE,$file) || return(1); - while (<FILE>) { if ( /^{-# OPTIONS (.*)#-}/ ) { # add the options found at the back of the command line. - push(@FileArgs, split(/\s+/, $1)); + local(@entries) = split(/\s+/,$1); + push(@File_options, @entries); } elsif ( /^$/ ) { # ignore empty lines ; } - else { + else { # stop looking, something non-empty / not + # {-# OPTIONS .. #-} encountered. break; } } @@ -2385,11 +2463,12 @@ sub check_for_source_options { \end{code} -split up argv into three arrays: +We split the initial argv up into three arrays: - @Cmd_opts - @Link_file - @Input_file + the reason for doing so is to be able to deal with {-# OPTIONS #-} pragma in source files properly. @@ -2399,8 +2478,8 @@ sub splitCmdLine { arg: while($_ = $args[0]) { shift(@args); - # sigh, we have to deal with the -option arg specially. - /^-(tmpdir|odir|o|isuf|osuf|hisuf|odump|syslib)$/ && + # sigh, we have to deal with these -option arg specially here. + /^-(tmpdir|odir|o|isuf|osuf|hisuf|hisuf-prelude|odump|syslib)$/ && do { push(@Cmd_opts, $_); push(@Cmd_opts,$args[0]); shift(@args); next arg; }; /^-./ && do { push(@Cmd_opts, $_); next arg; }; @@ -2415,11 +2494,12 @@ arg: while($_ = $args[0]) { print STDERR "$Pgm: input file doesn't exist: $_\n"; $Status++; } -} + } } \end{code} +Command-line processor \begin{code} sub processArgs { @@ -2434,7 +2514,7 @@ arg: while($_ = $Args[0]) { if (/^-\?$/ || /^--?help$/) { print $LongUsage; exit $Status; } #-----------version ---------------------------------------------------- - /^--version$/ && do { print STDERR "$(PROJECTNAME), version $(PROJECTVERSION) $(PROJECTPATCHLEVEL)\n"; exit $Status; }; + /^--version$/ && do { print STDERR "${PROJECTNAME}, version ${PROJECTVERSION} ${PROJECTPATCHLEVEL}\n"; exit $Status; }; #---------- verbosity and such ----------------------------------------- /^-v$/ && do { $Verbose = '-v'; $Time = 'time'; next arg; }; @@ -2470,9 +2550,8 @@ arg: while($_ = $Args[0]) { $Only_preprocess_C = 1; $Do_as = 0; $Do_lnkr = 0; next arg; }; # stop after preprocessing C - /^-M$/ && do { $Only_generate_deps = 1; - $Do_as = 0; $Do_lnkr = 0; next arg; }; - # only generate + /^-M$/ && do { $Only_generate_deps = 1; $Do_as = 0; $Do_lnkr = 0; next arg; }; + # only generate dependency information. /^-S$/ && do { $Do_as = 0; $Do_lnkr = 0; next arg; }; # stop after generating assembler @@ -2496,7 +2575,11 @@ arg: while($_ = $Args[0]) { # if <file> has a directory component, that dir must already exist /^-odir$/ && do { $Specific_output_dir = &grab_arg_arg(*Args,'-odir', ''); - if (! -d $Specific_output_dir) { + # + # Hack, of the worst sort: don't do validation of + # odir argument if you're using -M (dependency generation). + # + if ( ! $Only_generate_deps && ! -d $Specific_output_dir) { print STDERR "$Pgm: -odir: no such directory: $Specific_output_dir\n"; $Status++; } @@ -2540,12 +2623,20 @@ arg: while($_ = $Args[0]) { } next arg; }; + # The suffix to use when looking for interface files /^-hisuf$/ && do { $HiSuffix = &grab_arg_arg(*Args,'-hisuf', ''); if ($HiSuffix =~ /\./ ) { print STDERR "$Pgm: -hisuf suffix shouldn't contain a .\n"; $Status++; } next arg; }; + # ToDo: remove, not a `normal' user thing to do (should be automatic) + /^-hisuf-prelude$/ && do { $HiSuffix_prelude = &grab_arg_arg(*Args,'-hisuf-prelude', ''); + if ($HiSuffix =~ /\./ ) { + print STDERR "$Pgm: -hisuf-prelude suffix shouldn't contain a .\n"; + $Status++; + } + next arg; }; /^-odump$/ && do { $Specific_dump_file = &grab_arg_arg(*Args,'-odump', ''); if ($Specific_dump_file =~ /(.*)\/[^\/]*$/) { local($dir_part) = $1; @@ -2582,8 +2673,8 @@ arg: while($_ = $Args[0]) { next arg; }; /^-unprof-scc-auto/ && do { - # generate auto SCCs on top level bindings when not profiling - # used to measure optimisation effects of presence of sccs + # generate auto SCCs on top level bindings when not profiling. + # Used to measure optimisation effects of presence of sccs. $UNPROFscc_auto = ( /-all/ ) ? '-fauto-sccs-on-all-toplevs' : '-fauto-sccs-on-exported-toplevs'; @@ -2595,57 +2686,14 @@ arg: while($_ = $Args[0]) { /^-concurrent$/ && do { $CONCURing = 'c'; next arg; }; # concurrent Haskell /^-gransim$/ && do { $GRANing = 'g'; next arg; }; # GranSim /^-ticky$/ && do { $TICKYing = 't'; next arg; }; # ticky-ticky - /^-parallel$/ && do { $PARing = 'p'; next arg; } ; # parallel Haskell + /^-parallel$/ && do { $PARing = 'p'; next arg; }; # parallel Haskell #-------------- "user ways" -------------------------------------------- - (/^-user-setup-([a-oA-Z])$/ - || /^$(GHC_BUILD_FLAG_a)$/ - || /^$(GHC_BUILD_FLAG_b)$/ - || /^$(GHC_BUILD_FLAG_c)$/ - || /^$(GHC_BUILD_FLAG_d)$/ - || /^$(GHC_BUILD_FLAG_e)$/ - || /^$(GHC_BUILD_FLAG_f)$/ - || /^$(GHC_BUILD_FLAG_g)$/ - || /^$(GHC_BUILD_FLAG_h)$/ - || /^$(GHC_BUILD_FLAG_i)$/ - || /^$(GHC_BUILD_FLAG_j)$/ - || /^$(GHC_BUILD_FLAG_k)$/ - || /^$(GHC_BUILD_FLAG_l)$/ - || /^$(GHC_BUILD_FLAG_m)$/ - || /^$(GHC_BUILD_FLAG_n)$/ - || /^$(GHC_BUILD_FLAG_o)$/ - || /^$(GHC_BUILD_FLAG_A)$/ - || /^$(GHC_BUILD_FLAG_B)$/ - - || /^$(GHC_BUILD_FLAG_2s)$/ # GC ones... - || /^$(GHC_BUILD_FLAG_1s)$/ - || /^$(GHC_BUILD_FLAG_du)$/ - ) && do { + (/^-user-setup-([a-oA-Z])$/ ) && + do { /^-user-setup-([a-oA-Z])$/ && do { $BuildTag = "_$1"; }; - /^$(GHC_BUILD_FLAG_a)$/ && do { $BuildTag = '_a'; }; - /^$(GHC_BUILD_FLAG_b)$/ && do { $BuildTag = '_b'; }; - /^$(GHC_BUILD_FLAG_c)$/ && do { $BuildTag = '_c'; }; - /^$(GHC_BUILD_FLAG_d)$/ && do { $BuildTag = '_d'; }; - /^$(GHC_BUILD_FLAG_e)$/ && do { $BuildTag = '_e'; }; - /^$(GHC_BUILD_FLAG_f)$/ && do { $BuildTag = '_f'; }; - /^$(GHC_BUILD_FLAG_g)$/ && do { $BuildTag = '_g'; }; - /^$(GHC_BUILD_FLAG_h)$/ && do { $BuildTag = '_h'; }; - /^$(GHC_BUILD_FLAG_i)$/ && do { $BuildTag = '_i'; }; - /^$(GHC_BUILD_FLAG_j)$/ && do { $BuildTag = '_j'; }; - /^$(GHC_BUILD_FLAG_k)$/ && do { $BuildTag = '_k'; }; - /^$(GHC_BUILD_FLAG_l)$/ && do { $BuildTag = '_l'; }; - /^$(GHC_BUILD_FLAG_m)$/ && do { $BuildTag = '_m'; }; - /^$(GHC_BUILD_FLAG_n)$/ && do { $BuildTag = '_n'; }; - /^$(GHC_BUILD_FLAG_o)$/ && do { $BuildTag = '_o'; }; - /^$(GHC_BUILD_FLAG_A)$/ && do { $BuildTag = '_A'; }; - /^$(GHC_BUILD_FLAG_B)$/ && do { $BuildTag = '_B'; }; - - /^$(GHC_BUILD_FLAG_2s)$/ && do { $BuildTag = '_2s'; }; - /^$(GHC_BUILD_FLAG_1s)$/ && do { $BuildTag = '_1s'; }; - /^$(GHC_BUILD_FLAG_du)$/ && do { $BuildTag = '_du'; }; - local($stuff) = $UserSetupOpts{$BuildTag}; local(@opts) = split(/\s+/, $stuff); @@ -2678,11 +2726,11 @@ arg: while($_ = $Args[0]) { $Status++ unless $syslib =~ /^(hbc|ghc|posix|contrib)$/; unshift(@SysImport_dir, - $(INSTALLING) + ${INSTALLING} ? "$InstSysLibDir/$syslib/imports" : "$TopPwd/hslibs/$syslib/src"); - if ( $(INSTALLING) ) { + if ( ${INSTALLING} ) { push(@SysLibrary_dir, ("$InstSysLibDir/$TargetPlatform")); } else { @@ -2718,6 +2766,7 @@ arg: while($_ = $Args[0]) { /^-optP(.*)$/ && do { push(@HsCpp_flags, $1); next arg; }; /^-optCrts(.*)$/&& do { push(@HsC_rts_flags, $1); next arg; }; /^-optC(.*)$/ && do { push(@HsC_flags, $1); next arg; }; + /^-optcpp(.*)$/ && do { push(@Cpp_define, $1); next arg; }; /^-optc(.*)$/ && do { push(@CcBoth_flags, $1); next arg; }; /^-opta(.*)$/ && do { push(@As_flags, $1); next arg; }; /^-optl(.*)$/ && do { push(@Ld_flags, $1); next arg; }; @@ -2745,6 +2794,22 @@ arg: while($_ = $Args[0]) { /^-fignore-interface-pragmas$/ && do { push(@HsC_flags, $_); next arg; }; /^-fno-implicit-prelude$/ && do { $NoImplicitPrelude= 1; push(@HsC_flags, $_); next arg; }; + # don't do stack checking using page fault `trick'. + # (esoteric). + /^-fstack-check$/ && do { $StkChkByPageFaultOK = 0; next arg; }; + # + # have the compiler proper generate concurrent code, + # really only used when you want to configure your own + # special user compilation way. (Use -concurrent when + # compiling `Concurrent Haskell' programs). + # + # (ditto for -fgransim, fscc-profiling and -fticky-ticky) + # + /^-fconcurrent$/ && do { push(@HsC_flags,$_); next arg; }; + /^-fscc-profiling$/ && do { push(@HsC_flags,$_); next arg; }; + /^-fticky-ticky$/ && do { push(@HsC_flags,$_); next arg; }; + /^-fgransim$/ && do { push(@HsC_flags,$_); next arg; }; + /^-user-prelude-force/ && do { # ignore if not -user-prelude next arg; }; @@ -2843,18 +2908,22 @@ arg: while($_ = $Args[0]) { } next arg; }; - # --------------- + # --------------- Warnings etc. ------ + + /^-f(show-import-specs)/ + && do { push(@HsC_flags, $_); next arg; }; + # for now, just -fwarn-name-shadowing + /^-fwarn-(.*)$/ && do { push(@HsC_flags, $_); next arg; }; /^-fno-(.*)$/ && do { push(@HsC_antiflags, "-f$1"); &squashHscFlag("-f$1"); next arg; }; - /^-f(show-import-specs)/ - && do { push(@HsC_flags, $_); next arg; }; - # --------------- platform specific flags (for gcc mostly) ---------------- - /^-mlong-calls$/ && do { # for GCC for HP-PA boxes + /^-mlong-calls$/ && do { # for GCC for HP-PA boxes, + # for 2.6.x..?, does not apply for 2.7.2 + # any longer. unshift(@CcBoth_flags, ( $_ )); next arg; }; @@ -2872,6 +2941,9 @@ arg: while($_ = $Args[0]) { # -d(no-)core-lint is done this way so it is turn-off-able. /^-dcore-lint/ && do { $CoreLint = '-dcore-lint'; next arg; }; /^-dno-core-lint/ && do { $CoreLint = ''; next arg; }; + # Ditto for STG lint + /^-dstg-lint/ && do { $StgLint = '-dstg-lint'; next arg; }; + /^-dno-stg-lint/ && do { $StgLint = ''; next arg; }; /^-d(dump|ppr)-/ && do { push(@HsC_flags, $_); next arg; }; /^-dverbose-(simpl|stg)/ && do { push(@HsC_flags, $_); next arg; }; @@ -2909,6 +2981,7 @@ arg: while($_ = $Args[0]) { next arg; }; /^-(K|Rmax-(stk|stack)size)(.*)/ && do { + local($flag) = $1; local($stk_size) = &grab_arg_arg(*Args,'-Rmax-stksize', $3); if ($stk_size =~ /(\d+)[Kk]$/) { $stk_size = $1 * 1000; @@ -2918,14 +2991,14 @@ arg: while($_ = $Args[0]) { $stk_size = $1 * 1000 * 1000 * 1000; } if ($stk_size <= 0) { - print STDERR "$Pgm: resetting stack-size to zero!!!\n"; + print STDERR "$Pgm: resetting stack-size to zero!!! $stk_size\n"; $Specific_stk_size = 0; # if several stack sizes given, take the largest... } elsif ($stk_size >= $Specific_stk_size) { $Specific_stk_size = $stk_size; } else { - print STDERR "$Pgm: ignoring stack-size-setting option (-Rmax-stksize $stk_size)...not the largest seen\n"; + print STDERR "$Pgm: ignoring stack-size-setting option ($flag $stk_size)...not the largest seen\n"; } next arg; }; @@ -2961,7 +3034,6 @@ arg: while($_ = $Args[0]) { /^-O2-for-C$/ && do { $MinusO2ForC = 1; next arg; }; /^-O[1-2]?$/ && do { -# print STDERR "$Pgm: NOTE: this version of GHC doesn't support -O or -O2\n"; local($opt_lev) = ( /^-O2$/ ) ? 2 : 1; # max 'em $OptLevel = ( $opt_lev > $OptLevel ) ? $opt_lev : $OptLevel; diff --git a/ghc/driver/prefix.txt b/ghc/driver/prefix.txt new file mode 100644 index 0000000000..2ca01d140c --- /dev/null +++ b/ghc/driver/prefix.txt @@ -0,0 +1,12 @@ +# +# This is the driver script for the Glasgow Haskell Compiler. +# +# To configure this script to run on your system, you have +# to set the following three variables (if they have not already +# been set above): +# +#$TOP_PWD='/local/fp/'; +#$INSTLIBDIR_GHC='/local/fp/bin/ghc-2.02'; +#$INSTDATADIR_GHC='/local/fp/lib/ghc-2.02/sparc-sun-sunos4'; +#$PERL='/usr/local/bin/perl'; +# diff --git a/ghc/lib/cbits/getCPUTime.lc b/ghc/lib/cbits/getCPUTime.lc new file mode 100644 index 0000000000..bc4f930b92 --- /dev/null +++ b/ghc/lib/cbits/getCPUTime.lc @@ -0,0 +1,105 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getCPUTime.lc]{getCPUTime Runtime Support} + +\begin{code} + +#define NON_POSIX_SOURCE /*needed for solaris2 only?*/ + +/* how is this to work given we have not read platform.h yet? */ +#ifdef hpux_TARGET_OS +#define _INCLUDE_HPUX_SOURCE +#endif + +#include "rtsdefs.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_SYS_TIMES_H +#include <sys/times.h> +#endif + +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#endif + +#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS +#include <sys/resource.h> +#endif + +#ifdef HAVE_SYS_TIMEB_H +#include <sys/timeb.h> +#endif + +#ifdef hpux_TARGET_OS +#include <sys/syscall.h> +#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b) +#define HAVE_GETRUSAGE +#endif + +StgInt +clockTicks () +{ + return ( +#if defined(CLK_TCK) + CLK_TCK +#else + sysconf(_SC_CLK_TCK) +#endif + ); +} + +/* + * Our caller wants a pointer to four StgInts, + * user seconds, user nanoseconds, system seconds, system nanoseconds. + * Yes, the timerval has unsigned components, but nanoseconds take only + * 30 bits, and our CPU usage would have to be over 68 years for the + * seconds to overflow 31 bits. + */ + +StgByteArray +getCPUTime(StgByteArray cpuStruct) +{ + StgInt *cpu=(StgInt *)cpuStruct; + +#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS + struct rusage t; + + getrusage(RUSAGE_SELF, &t); + cpu[0] = t.ru_utime.tv_sec; + cpu[1] = 1000 * t.ru_utime.tv_usec; + cpu[2] = t.ru_stime.tv_sec; + cpu[3] = 1000 * t.ru_stime.tv_usec; + +#else +# if defined(HAVE_TIMES) + struct tms t; +# if defined(CLK_TCK) +# define ticks CLK_TCK +# else + long ticks; + ticks = sysconf(_SC_CLK_TCK); +# endif + + times(&t); + cpu[0] = t.tms_utime / ticks; + cpu[1] = (t.tms_utime - cpu[0] * ticks) * (1000000000 / ticks); + cpu[2] = t.tms_stime / ticks; + cpu[3] = (t.tms_stime - cpu[2] * ticks) * (1000000000 / ticks); + +# else + return NULL; +# endif +#endif + return (StgByteArray) cpuStruct; +} + +\end{code} + diff --git a/ghc/lib/cbits/stgio.h b/ghc/lib/cbits/stgio.h index 82b223f9cd..8c0d2cb8be 100644 --- a/ghc/lib/cbits/stgio.h +++ b/ghc/lib/cbits/stgio.h @@ -50,6 +50,10 @@ StgInt fileSize PROTO((StgForeignObj, StgByteArray)); /* flushFile.lc */ StgInt flushFile PROTO((StgForeignObj)); +/* freeFile.lc */ +void freeStdChannel PROTO((StgForeignObj)); +void freeFile PROTO((StgForeignObj)); + /* getBufferMode.lc */ StgInt getBufferMode PROTO((StgForeignObj)); @@ -58,6 +62,7 @@ StgInt getClockTime PROTO((StgByteArray, StgByteArray)); /* getCPUTime.lc */ StgByteArray getCPUTime PROTO((StgByteArray)); +StgInt clockTicks(); /* getCurrentDirectory.lc */ StgAddr getCurrentDirectory(STG_NO_ARGS); @@ -76,10 +81,6 @@ StgInt inputReady PROTO((StgForeignObj)); /* openFile.lc */ StgAddr openFile PROTO((StgByteArray, StgByteArray)); -/* freeFile.lc */ -void freeStdChannel PROTO((StgForeignObj)); -void freeFile PROTO((StgForeignObj)); - /* readFile.lc */ StgInt readBlock PROTO((StgAddr, StgForeignObj, StgInt)); StgInt readLine PROTO((StgAddr, StgForeignObj, StgInt)); diff --git a/ghc/lib/required/CPUTime.lhs b/ghc/lib/required/CPUTime.lhs new file mode 100644 index 0000000000..c24a142088 --- /dev/null +++ b/ghc/lib/required/CPUTime.lhs @@ -0,0 +1,51 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997 +% +\section[CPUTime]{Haskell 1.4 CPU Time Library} + +\begin{code} +module CPUTime + ( + getCPUTime, -- :: IO Integer + cpuTimePrecision -- :: Integer + ) where + +import PrelBase (Int(..), indexIntArray#, Addr(..) ) +import ArrBase --(ByteArray(..)) +import IOBase +import IO +import STBase +import Ratio + +\end{code} + +Computation @getCPUTime@ returns the number of picoseconds CPU time +used by the current program. The precision of this result is +implementation-dependent. + +The @cpuTimePrecision@ constant is the resolution (in picoseconds!) of +the number of + +\begin{code} +getCPUTime :: IO Integer +getCPUTime = + newIntArray (0,3) `thenIO_Prim` \ marr -> + unsafeFreezeByteArray marr `thenIO_Prim` \ barr@(ByteArray _ frozen#) -> + _ccall_ getCPUTime barr `thenIO_Prim` \ ptr -> + if (ptr::Addr) /= ``NULL'' then + return ((fromIntegral (I# (indexIntArray# frozen# 0#)) * 1000000000 + + fromIntegral (I# (indexIntArray# frozen# 1#)) + + fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 + + fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000) + else + fail (IOError Nothing UnsupportedOperation "getCPUTime: can't get CPU time") + +cpuTimePrecision :: Integer +cpuTimePrecision = round ((1000000000000::Integer) % + fromInt (unsafePerformPrimIO (_ccall_ clockTicks ))) +\end{code} + + + + + diff --git a/ghc/lib/tests/Array/arr001/Main.hs b/ghc/lib/tests/Array/arr001/Main.hs new file mode 100644 index 0000000000..4785170771 --- /dev/null +++ b/ghc/lib/tests/Array/arr001/Main.hs @@ -0,0 +1,9 @@ +-- Simple array creation + +import Array + +main = + let a1 = array (1,3) (zip [2,3,1] ['a'..'d']) in + print a1 + +-- Result: diff --git a/ghc/lib/tests/Array/arr001/Makefile b/ghc/lib/tests/Array/arr001/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr001/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr002/Main.hs b/ghc/lib/tests/Array/arr002/Main.hs new file mode 100644 index 0000000000..fd3bf7e3dd --- /dev/null +++ b/ghc/lib/tests/Array/arr002/Main.hs @@ -0,0 +1,23 @@ +-- Array creation, (index,value) list with duplicates. +-- +-- Haskell library report 1.3 (and earlier) specifies +-- that `array' values created with lists containing dups, +-- are undefined ( _|_ ). +-- +-- GHC-2.02 (and earlier) does not flag this as such, the +-- last (index,value) is instead used. +-- +-- The report also specifies `array' is spine strict in +-- the (index,value) list argument and to check the +-- validity of the index values upon creation, it also +-- strict for the indices. To test this, we do (a!1) +-- twice, expecting to see the same value.. +-- +import Array + +main = + let a1 = array (1,3) (zip (1:[1..3]) ['a'..'d']) in + print (a1!1) >> + print a1 >> + print (a1!1) + diff --git a/ghc/lib/tests/Array/arr002/Makefile b/ghc/lib/tests/Array/arr002/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr002/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr003/Main.hs b/ghc/lib/tests/Array/arr003/Main.hs new file mode 100644 index 0000000000..0dbe42bc0e --- /dev/null +++ b/ghc/lib/tests/Array/arr003/Main.hs @@ -0,0 +1,19 @@ +-- Array creation, (index,value) list with out of bound index. +-- +-- Haskell library report 1.3 (and earlier) specifies +-- that `array' values created with lists containing out-of-bounds indices, +-- are undefined ( _|_ ). +-- +-- GHC implementation of `array' catches this (or, rather, +-- `index' does) - the argument list to `array' is defined +-- to have its spine be evaluated - so the indexing below +-- should cause a failure. +-- +import Array + +main = + let a1 = array (1,3) (zip ([1..4]) ['a'..'d']) in + print (a1!2) + + + diff --git a/ghc/lib/tests/Array/arr003/Makefile b/ghc/lib/tests/Array/arr003/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr003/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr004/Main.hs b/ghc/lib/tests/Array/arr004/Main.hs new file mode 100644 index 0000000000..5a1283435f --- /dev/null +++ b/ghc/lib/tests/Array/arr004/Main.hs @@ -0,0 +1,15 @@ +-- Array - accessing undefined element +-- +-- Sample Haskell implementation in the 1.3 Lib report defines +-- this as being undefined/error. + +import Array + +main = + let a1 = array (1,3) (zip ([1,2]) ['a'..'d']) in + print (a1!3) + +-- output: Fail: (Array.!): undefined array element + + + diff --git a/ghc/lib/tests/Array/arr004/Makefile b/ghc/lib/tests/Array/arr004/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr004/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr005/Main.hs b/ghc/lib/tests/Array/arr005/Main.hs new file mode 100644 index 0000000000..6d531cdac8 --- /dev/null +++ b/ghc/lib/tests/Array/arr005/Main.hs @@ -0,0 +1,16 @@ +-- Array - recurrences +-- +-- array does not evaluate the elements. +-- +import Array + +main = + let + a1 = array (1,100) ((1,1::Integer):[(i,i*a1!(i-1))|i<-[2..100]]) + in + print a1 + +-- + + + diff --git a/ghc/lib/tests/Array/arr005/Makefile b/ghc/lib/tests/Array/arr005/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr005/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr006/Main.hs b/ghc/lib/tests/Array/arr006/Main.hs new file mode 100644 index 0000000000..95abb1cfb5 --- /dev/null +++ b/ghc/lib/tests/Array/arr006/Main.hs @@ -0,0 +1,11 @@ +-- Array - empty arrays +-- +-- print a couple of them to try to expose empty arrays +-- to a GC or two. +import Array + +main = + let + a1 = array (1,0) [] + in + print (take 300 $ repeat (a1 :: Array Int Int)) diff --git a/ghc/lib/tests/Array/arr006/Makefile b/ghc/lib/tests/Array/arr006/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr006/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr007/Main.hs b/ghc/lib/tests/Array/arr007/Main.hs new file mode 100644 index 0000000000..e3e4ba0f7b --- /dev/null +++ b/ghc/lib/tests/Array/arr007/Main.hs @@ -0,0 +1,11 @@ +-- Array - accessing empty arrays +-- +-- empty arrays are legal, but indexing them is undefined! +-- +import Array + +main = + let + a1 = array (1,0) [(1,'a')] + in + print (a1!0) diff --git a/ghc/lib/tests/Array/arr007/Makefile b/ghc/lib/tests/Array/arr007/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr007/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr008/Main.hs b/ghc/lib/tests/Array/arr008/Main.hs new file mode 100644 index 0000000000..c066cddebb --- /dev/null +++ b/ghc/lib/tests/Array/arr008/Main.hs @@ -0,0 +1,14 @@ +-- Array - out-of-range (index,value) pairs +-- +-- supplying a list containing one or more pairs +-- with out-of-range index is undefined. +-- +-- +import Array + +main = + let + a1 = array (1,0) [] + a2 = array (0,1) (zip [0..] ['a'..'z']) + in + print (a1::Array Int Int) >> print a2 diff --git a/ghc/lib/tests/Array/arr008/Makefile b/ghc/lib/tests/Array/arr008/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr008/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr009/Main.hs b/ghc/lib/tests/Array/arr009/Main.hs new file mode 100644 index 0000000000..a6fe26e04d --- /dev/null +++ b/ghc/lib/tests/Array/arr009/Main.hs @@ -0,0 +1,17 @@ +-- Array - derived ops +-- +-- testing the well-behavedness of +-- derived ops for empty and non-empty arrays +-- +import Array + +main = + let + a1 = array (1,0) ([]::[(Int,Int)]) + a2 = array (1,26) (zip [1..] ['a'..'z']) + + dump a = (bounds a, indices a, elems a, assocs a) + in + print (dump a1) >> + print (dump a2) + diff --git a/ghc/lib/tests/Array/arr009/Makefile b/ghc/lib/tests/Array/arr009/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr009/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr010/Main.hs b/ghc/lib/tests/Array/arr010/Main.hs new file mode 100644 index 0000000000..2952bec529 --- /dev/null +++ b/ghc/lib/tests/Array/arr010/Main.hs @@ -0,0 +1,19 @@ +-- +-- Array - accumulated arrays +-- +-- +module Main(main) where + +import Array +import Ix + +hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b +hist bnds is = accumArray (+) 0 bnds [(i,1) | i <- is , inRange bnds i] + +main = + let + a1 = hist (0,10) (concat $ take 2 $ repeat [1..20]) + in + print a1 + + diff --git a/ghc/lib/tests/Array/arr010/Makefile b/ghc/lib/tests/Array/arr010/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr010/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr011/Main.hs b/ghc/lib/tests/Array/arr011/Main.hs new file mode 100644 index 0000000000..76ad1780ee --- /dev/null +++ b/ghc/lib/tests/Array/arr011/Main.hs @@ -0,0 +1,20 @@ +-- Array - array difference operator +-- +-- +module Main(main) where + +import Array +import Ix + +hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b +hist bnds is = accumArray (+) 0 bnds [(i,1) | i <- is , inRange bnds i] + +main = + let + a1 = hist (0,10) (concat $ take 2 $ repeat [1..20]) + in + print a1 >> + print (a1 // [ (i,0) | i<-[0..10], odd i]) + + + diff --git a/ghc/lib/tests/Array/arr011/Makefile b/ghc/lib/tests/Array/arr011/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr011/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/lib/tests/Array/arr012/Main.hs b/ghc/lib/tests/Array/arr012/Main.hs new file mode 100644 index 0000000000..61dc0bf5f8 --- /dev/null +++ b/ghc/lib/tests/Array/arr012/Main.hs @@ -0,0 +1,19 @@ +-- Array map operations +-- +-- +module Main(main) where + +import Array +import Char + +main = + let + a1 = array (0,10) (zip [0..10] ['a'..'z']) + in + print a1 >> + print (map (toUpper) a1) >> + print (ixmap (3,8) (+1) a1) + + + + diff --git a/ghc/lib/tests/Array/arr012/Makefile b/ghc/lib/tests/Array/arr012/Makefile new file mode 100644 index 0000000000..f66958d07b --- /dev/null +++ b/ghc/lib/tests/Array/arr012/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/target.mk diff --git a/ghc/mk/boilerplate.mk b/ghc/mk/boilerplate.mk new file mode 100644 index 0000000000..96782a0a79 --- /dev/null +++ b/ghc/mk/boilerplate.mk @@ -0,0 +1,34 @@ +################################################################################# +# +# GHC boilerplate.mk +# +# Boilerplate Makefile for an fptools project +# +################################################################################# + +# Begin by slurping in the boilerplate from one level up. +# Remember, TOP is the top level of the innermost level +# (FPTOOLS_TOP is the fptools top) + +# We need to set TOP to be the TOP that the next level up expects! +# The TOP variable is reset after the inclusion of the fptools +# boilerplate, so we stash TOP away first: +GHC_TOP := $(TOP) +TOP:=$(TOP)/.. + +include $(TOP)/mk/boilerplate.mk + +# Reset TOP +TOP:=$(GHC_TOP) + +# ----------------------------------------------------------------- +# Everything after this point +# augments or overrides previously set variables. +# (these files are optional, so `make' won't fret if +# cannot get to them). +# ----------------------------------------------------------------- + +-include $(TOP)/mk/paths.mk +-include $(TOP)/mk/opts.mk +include $(TOP)/mk/suffix.mk + diff --git a/ghc/mk/buildflags.mk b/ghc/mk/buildflags.mk deleted file mode 100644 index 97cdd0ea8a..0000000000 --- a/ghc/mk/buildflags.mk +++ /dev/null @@ -1,198 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: buildflags.mk,v 1.3 1997/01/21 10:51:19 sof Exp $ - -# This stuff is used by the Makefiles in lib/ and runtime/. - -ifdef DoingRTS -GCap = -optc-DGCap -GC2s = -optc-DGC2s -GC1s = -optc-DG1s -endif - -GHC_OPTS_norm=-O $(GCap) -GHC_OPTS_p =-O -prof -GPrelude $(GCap) -hisuf p_hi -GHC_OPTS_t =-O -ticky -optc-DDEBUG $(GCap) -hisuf t_hi -GHC_OPTS_u =-O -unregisterised ???? -ticky $(GCap) -hisuf u_hi -GHC_OPTS_mc=-O -concurrent $(GCap) -hisuf mc_hi -GHC_OPTS_mr=-O -concurrent -prof -GPrelude $(GCap) -hisuf mr_hi -GHC_OPTS_mt=-O -concurrent -ticky -optc-DDEBUG $(GCap) -hisuf mt_hi -GHC_OPTS_mp=-O -parallel $(GCap) -hisuf mp_hi -GHC_OPTS_mg=-O -gransim $(GCap) -hisuf mg_hi - -GHC_OPTS_2s=-O -gc-2s $(GC2s) -hisuf 2s_hi -GHC_OPTS_1s=-O -gc-1s $(GC1s) -hisuf 1s_hi -GHC_OPTS_du=-O -gc-du $(GCdu) -hisuf du_hi - -GHC_OPTS_a =-user-setup-a $(GCap) -hisuf a_hi -GHC_OPTS_b =-user-setup-b $(GCap) -hisuf b_hi -GHC_OPTS_c =-user-setup-c $(GCap) -hisuf c_hi -GHC_OPTS_d =-user-setup-d $(GCap) -hisuf d_hi -GHC_OPTS_e =-user-setup-e $(GCap) -hisuf e_hi -GHC_OPTS_f =-user-setup-f $(GCap) -hisuf f_hi -GHC_OPTS_g =-user-setup-g $(GCap) -hisuf g_hi -GHC_OPTS_h =-user-setup-h $(GCap) -hisuf h_hi -GHC_OPTS_i =-user-setup-i $(GCap) -hisuf i_hi -GHC_OPTS_j =-user-setup-j $(GCap) -hisuf j_hi -GHC_OPTS_k =-user-setup-k $(GCap) -hisuf k_hi -GHC_OPTS_l =-user-setup-l $(GCap) -hisuf l_hi -GHC_OPTS_m =-user-setup-m $(GCap) -hisuf m_hi -GHC_OPTS_n =-user-setup-n $(GCap) -hisuf n_hi -GHC_OPTS_o =-user-setup-o $(GCap) -hisuf o_hi -GHC_OPTS_A =-user-setup-A $(GCap) -hisuf A_hi -GHC_OPTS_B =-user-setup-B $(GCap) -hisuf B_hi - -# used in hslibs: - -HC_OPTS_norm= $(GHC_OPTS_norm) -HC_OPTS_p = $(GHC_OPTS_p) -HC_OPTS_t = $(GHC_OPTS_t) -HC_OPTS_u = $(GHC_OPTS_u) -HC_OPTS_mc= $(GHC_OPTS_mc) -HC_OPTS_mr= $(GHC_OPTS_mr) -HC_OPTS_mt= $(GHC_OPTS_mt) -HC_OPTS_mp= $(GHC_OPTS_mp) -HC_OPTS_mg= $(GHC_OPTS_mg) -HC_OPTS_2s= $(GHC_OPTS_2s) -HC_OPTS_1s= $(GHC_OPTS_1s) -HC_OPTS_du= $(GHC_OPTS_du) -HC_OPTS_a = $(GHC_OPTS_a) -HC_OPTS_b = $(GHC_OPTS_b) -HC_OPTS_c = $(GHC_OPTS_c) -HC_OPTS_d = $(GHC_OPTS_d) -HC_OPTS_e = $(GHC_OPTS_e) -HC_OPTS_f = $(GHC_OPTS_f) -HC_OPTS_g = $(GHC_OPTS_g) -HC_OPTS_h = $(GHC_OPTS_h) -HC_OPTS_i = $(GHC_OPTS_i) -HC_OPTS_j = $(GHC_OPTS_j) -HC_OPTS_k = $(GHC_OPTS_k) -HC_OPTS_l = $(GHC_OPTS_l) -HC_OPTS_m = $(GHC_OPTS_m) -HC_OPTS_n = $(GHC_OPTS_n) -HC_OPTS_o = $(GHC_OPTS_o) -HC_OPTS_A = $(GHC_OPTS_A) -HC_OPTS_B = $(GHC_OPTS_B) - -#----------------------------------------------------------------------------- -# Build up a list of the suffixes for which we're building - -# this stuff is used by the rts and lib Makefiles. - -WAY_SUFFIXES = - -ifeq ($(Build_normal), YES) -WAY_SUFFIXES += norm -endif - -ifeq ($(Build_p), YES) -WAY_SUFFIXES += p -endif - -ifeq ($(Build_t), YES) -WAY_SUFFIXES += t -endif - -ifeq ($(Build_u), YES) -WAY_SUFFIXES += u -endif - -ifeq ($(Build_mc), YES) -WAY_SUFFIXES += mc -endif - -ifeq ($(Build_mr), YES) -WAY_SUFFIXES += mr -endif - -ifeq ($(Build_mt), YES) -WAY_SUFFIXES += mt -endif - -ifeq ($(Build_mp), YES) -WAY_SUFFIXES += mp -endif - -ifeq ($(Build_mg), YES) -WAY_SUFFIXES += mg -endif - -ifeq ($(Build_2s), YES) -WAY_SUFFIXES += 2s -endif - -ifeq ($(Build_1s), YES) -WAY_SUFFIXES += 1s -endif - -ifeq ($(Build_du), YES) -WAY_SUFFIXES += du -endif - -ifeq ($(Build_a), YES) -WAY_SUFFIXES += a -endif - -ifeq ($(Build_b), YES) -WAY_SUFFIXES += b -endif - -ifeq ($(Build_c), YES) -WAY_SUFFIXES += c -endif - -ifeq ($(Build_d), YES) -WAY_SUFFIXES += d -endif - -ifeq ($(Build_e), YES) -WAY_SUFFIXES += e -endif - -ifeq ($(Build_f), YES) -WAY_SUFFIXES += f -endif - -ifeq ($(Build_g), YES) -WAY_SUFFIXES += g -endif - -ifeq ($(Build_h), YES) -WAY_SUFFIXES += h -endif - -ifeq ($(Build_i), YES) -WAY_SUFFIXES += i -endif - -ifeq ($(Build_j), YES) -WAY_SUFFIXES += j -endif - -ifeq ($(Build_k), YES) -WAY_SUFFIXES += k -endif - -ifeq ($(Build_l), YES) -WAY_SUFFIXES += l -endif - -ifeq ($(Build_m), YES) -WAY_SUFFIXES += m -endif - -ifeq ($(Build_n), YES) -WAY_SUFFIXES += n -endif - -ifeq ($(Build_o), YES) -WAY_SUFFIXES += o -endif - -ifeq ($(Build_A), YES) -WAY_SUFFIXES += A -endif - -ifeq ($(Build_B), YES) -WAY_SUFFIXES += B -endif - diff --git a/ghc/mk/ghc-opts.mk b/ghc/mk/ghc-opts.mk deleted file mode 100644 index 4fda5b51ad..0000000000 --- a/ghc/mk/ghc-opts.mk +++ /dev/null @@ -1,192 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: ghc-opts.mk,v 1.3 1997/01/21 10:52:10 sof Exp $ - -ifdef DoingRTS -GCap = -optc-DGCap -GC2s = -optc-DGC2s -GC1s = -optc-DG1s -endif - -GHC_OPTS_norm=-O $(GCap) -GHC_OPTS_p =-O -prof -GPrelude $(GCap) -hisuf p_hi -GHC_OPTS_t =-O -ticky -optc-DDEBUG $(GCap) -hisuf t_hi -GHC_OPTS_u =-O -unregisterised ???? -ticky $(GCap) -hisuf u_hi -GHC_OPTS_mc=-O -concurrent $(GCap) -hisuf mc_hi -GHC_OPTS_mr=-O -concurrent -prof -GPrelude $(GCap) -hisuf mr_hi -GHC_OPTS_mt=-O -concurrent -ticky -optc-DDEBUG $(GCap) -hisuf mt_hi -GHC_OPTS_mp=-O -parallel $(GCap) -hisuf mp_hi -GHC_OPTS_mg=-O -gransim $(GCap) -hisuf mg_hi - -GHC_OPTS_2s=-O -gc-2s $(GC2s) -hisuf 2s_hi -GHC_OPTS_1s=-O -gc-1s $(GC1s) -hisuf 1s_hi -GHC_OPTS_du=-O -gc-du $(GCdu) -hisuf du_hi - -GHC_OPTS_a =-user-setup-a $(GCap) -hisuf a_hi -GHC_OPTS_b =-user-setup-b $(GCap) -hisuf b_hi -GHC_OPTS_c =-user-setup-c $(GCap) -hisuf c_hi -GHC_OPTS_d =-user-setup-d $(GCap) -hisuf d_hi -GHC_OPTS_e =-user-setup-e $(GCap) -hisuf e_hi -GHC_OPTS_f =-user-setup-f $(GCap) -hisuf f_hi -GHC_OPTS_g =-user-setup-g $(GCap) -hisuf g_hi -GHC_OPTS_h =-user-setup-h $(GCap) -hisuf h_hi -GHC_OPTS_i =-user-setup-i $(GCap) -hisuf i_hi -GHC_OPTS_j =-user-setup-j $(GCap) -hisuf j_hi -GHC_OPTS_k =-user-setup-k $(GCap) -hisuf k_hi -GHC_OPTS_l =-user-setup-l $(GCap) -hisuf l_hi -GHC_OPTS_m =-user-setup-m $(GCap) -hisuf m_hi -GHC_OPTS_n =-user-setup-n $(GCap) -hisuf n_hi -GHC_OPTS_o =-user-setup-o $(GCap) -hisuf o_hi -GHC_OPTS_A =-user-setup-A $(GCap) -hisuf A_hi -GHC_OPTS_B =-user-setup-B $(GCap) -hisuf B_hi - -# used in hslibs: - -HC_OPTS_norm= $(GHC_OPTS_norm) -HC_OPTS_p = $(GHC_OPTS_p) -HC_OPTS_t = $(GHC_OPTS_t) -HC_OPTS_u = $(GHC_OPTS_u) -HC_OPTS_mc= $(GHC_OPTS_mc) -HC_OPTS_mr= $(GHC_OPTS_mr) -HC_OPTS_mt= $(GHC_OPTS_mt) -HC_OPTS_mp= $(GHC_OPTS_mp) -HC_OPTS_mg= $(GHC_OPTS_mg) -HC_OPTS_2s= $(GHC_OPTS_2s) -HC_OPTS_1s= $(GHC_OPTS_1s) -HC_OPTS_du= $(GHC_OPTS_du) -HC_OPTS_a = $(GHC_OPTS_a) -HC_OPTS_b = $(GHC_OPTS_b) -HC_OPTS_c = $(GHC_OPTS_c) -HC_OPTS_d = $(GHC_OPTS_d) -HC_OPTS_e = $(GHC_OPTS_e) -HC_OPTS_f = $(GHC_OPTS_f) -HC_OPTS_g = $(GHC_OPTS_g) -HC_OPTS_h = $(GHC_OPTS_h) -HC_OPTS_i = $(GHC_OPTS_i) -HC_OPTS_j = $(GHC_OPTS_j) -HC_OPTS_k = $(GHC_OPTS_k) -HC_OPTS_l = $(GHC_OPTS_l) -HC_OPTS_m = $(GHC_OPTS_m) -HC_OPTS_n = $(GHC_OPTS_n) -HC_OPTS_o = $(GHC_OPTS_o) -HC_OPTS_A = $(GHC_OPTS_A) -HC_OPTS_B = $(GHC_OPTS_B) - -#----------------------------------------------------------------------------- -# Build up a list of the suffixes for which we're building - -# this stuff is used by the rts and lib Makefiles. - -WAY_SUFFIXES = - -ifeq ($(Build_p), YES) -WAY_SUFFIXES += p -endif - -ifeq ($(Build_t), YES) -WAY_SUFFIXES += t -endif - -ifeq ($(Build_u), YES) -WAY_SUFFIXES += u -endif - -ifeq ($(Build_mc), YES) -WAY_SUFFIXES += mc -endif - -ifeq ($(Build_mr), YES) -WAY_SUFFIXES += mr -endif - -ifeq ($(Build_mt), YES) -WAY_SUFFIXES += mt -endif - -ifeq ($(Build_mp), YES) -WAY_SUFFIXES += mp -endif - -ifeq ($(Build_mg), YES) -WAY_SUFFIXES += mg -endif - -ifeq ($(Build_2s), YES) -WAY_SUFFIXES += 2s -endif - -ifeq ($(Build_1s), YES) -WAY_SUFFIXES += 1s -endif - -ifeq ($(Build_du), YES) -WAY_SUFFIXES += du -endif - -ifeq ($(Build_a), YES) -WAY_SUFFIXES += a -endif - -ifeq ($(Build_b), YES) -WAY_SUFFIXES += b -endif - -ifeq ($(Build_c), YES) -WAY_SUFFIXES += c -endif - -ifeq ($(Build_d), YES) -WAY_SUFFIXES += d -endif - -ifeq ($(Build_e), YES) -WAY_SUFFIXES += e -endif - -ifeq ($(Build_f), YES) -WAY_SUFFIXES += f -endif - -ifeq ($(Build_g), YES) -WAY_SUFFIXES += g -endif - -ifeq ($(Build_h), YES) -WAY_SUFFIXES += h -endif - -ifeq ($(Build_i), YES) -WAY_SUFFIXES += i -endif - -ifeq ($(Build_j), YES) -WAY_SUFFIXES += j -endif - -ifeq ($(Build_k), YES) -WAY_SUFFIXES += k -endif - -ifeq ($(Build_l), YES) -WAY_SUFFIXES += l -endif - -ifeq ($(Build_m), YES) -WAY_SUFFIXES += m -endif - -ifeq ($(Build_n), YES) -WAY_SUFFIXES += n -endif - -ifeq ($(Build_o), YES) -WAY_SUFFIXES += o -endif - -ifeq ($(Build_A), YES) -WAY_SUFFIXES += A -endif - -ifeq ($(Build_B), YES) -WAY_SUFFIXES += B -endif - diff --git a/ghc/mk/ghc.mk b/ghc/mk/ghc.mk deleted file mode 100644 index 3e2bc91487..0000000000 --- a/ghc/mk/ghc.mk +++ /dev/null @@ -1,14 +0,0 @@ -# ----------------------------------------------------------------------------- -# $Id: ghc.mk,v 1.2 1996/11/21 16:48:00 simonm Exp $ - -# include the generic build stuff first... - -include $(TOP)/mk/gen.mk - -# then the specific GHC stuff, so we can override defaults if -# necessary. - -include $(TOP)/ghc/mk/buildinfo.mk -include $(TOP)/ghc/mk/site-ghc.mk -include $(TOP)/ghc/mk/ghcconfig.mk -include $(TOP)/ghc/mk/suffixes-ghc.mk diff --git a/ghc/mk/ghcconfig.mk.in b/ghc/mk/ghcconfig.mk.in deleted file mode 100644 index c47883a9e1..0000000000 --- a/ghc/mk/ghcconfig.mk.in +++ /dev/null @@ -1,237 +0,0 @@ -# ----------------------------------------------------------------------------- -# $Id: ghcconfig.mk.in,v 1.4 1997/01/21 11:05:37 sof Exp $ - -# This stuff should be split into separate files: that which can be -# messed with, and that which can't. - -# ============================================================================= -# Autoconf'ed stuff - -WithGhcHc = @WithGhcHc@ -WithGhcHcType = @WithGhcHcType@ - -# Override default haskell compiler if required -ifneq ($(WithGhcHcType),HC_UNSPECIFIED) -HC = $(WithGhcHc) -HaskellCompilerType = $(WithGhcHcType) -endif - -GhcWithHscBuiltViaC = @GhcWithHscBuiltViaC@ -GhcWithHscOptimised = @GhcWithHscOptimised@ -GhcWithHscDebug = @GhcWithHscDebug@ -GhcBuilderVersion = @GhcBuilderVersion@ -GhcWithRegisterised = @GhcWithRegisterised@ -GhcWithNativeCodeGen = @GhcWithNativeCodeGen@ - -GhcWithDeforester = @GhcWithDeforester@ -GhcWithReadline = @GhcWithReadline@ -GhcWithSockets = @GhcWithSockets@ - -# ===================================================================== -# Utilties for ghc project - -ifeq ($(GhcWithHscOptimised), YES) -__hsc_opt = -O -else -__hsc_opt = -endif - -ifeq ($(HaskellCompilerType), HC_CHALMERS_HBC) -PROJECT_HC_OPTS = $(__hsc_opt) -fpbu -else -ifeq ($(HaskellCompilerType), HC_GLASGOW_GHC) -PROJECT_HC_OPTS = $(__hsc_opt) -hi-diffs -link-chk -else -ifeq ($(HaskellCompilerType),HC_ROJEMO_NHC) -PROJECT_HC_OPTS = -else -PROJECT_HC_OPTS = -endif -endif -endif - -ifeq ($(HaveGcc), YES) -ifeq ($(UseGcc), YES) -PROJECT_CC_OPTS = -O -endif -endif - -PROJECT_MSUB_OPTS = -f $(TOP)/ghc/mk/ghcconfig.mk -f $(TOP)/ghc/mk/buildinfo.mk -f $(TOP)/ghc/mk/site-ghc.mk - -#----------------------------------------------------------------------------- -# MkDependHS - -ifdef UseInstalledUtils -MKDEPENDHS = $(GHC_DRIVER_INST_NAME) -M -else -MKDEPENDHS = $(GHC_DRIVERSRC)/ghc -M -MKDEPENDHSSRC = $(GHC_UTILSRC)/mkdependHS -endif - -# Temp until we bootstrap to 2.01 properly -ifeq ($(Ghc2_0),YES) - MKDEPENDHS = $(GHC_DRIVERSRC)/ghc -M -else - MKDEPENDHS = mkdependHS-1.2 -endif - -#----------------------------------------------------------------------------- -# Unlit - -UNLIT = $(GHC_UNLITSRC)/unlit - -#ToDo: unlitNeededHere - -GHC_UNLIT = $(UNLIT) -GHC_UNLITSRC = $(GHC_UTILSRC)/unlit - -#----------------------------------------------------------------------------- -# HsTags - -ifdef UseInstalledUtils -HSTAGS = hstags -else -HSTAGS = $(HSTAGSSRC)/hstags -HSTAGSSRC = $(GHC_UTILSRC)/hstags -endif - -GLUED_HSTAGS_OPTS = \ - $(ALL_PROJECTS_HSTAGS_OPTS) \ - $(PLATFORM_HSTAGS_OPTS) \ - $(PROJECT_HSTAGS_OPTS) \ - $(HSTAGS_OPTS) \ - $(EXTRA_HSTAGS_OPTS) - -HSTAGSFLAGS = $(GLUED_HSTAGS_OPTS) - -#----------------------------------------------------------------------------- -# Ugen - -ifdef UseInstalledUtils -UGEN = ugen -else -UGEN = $(UGENSRC)/ugen -UGENSRC = $(GHC_UTILSRC)/ugen -endif - -#----------------------------------------------------------------------------- -# Extra things ``only for'' for the ghc project - -PROJECTNAME = The Glorious Glasgow Haskell Compilation System -PROJECTVERSION = 2.01 -PROJECTPATCHLEVEL = patchlevel 0 -GhcBuildeeVersion = 201 - -GHC_DRIVERSRC = $(TOP)/ghc/driver -GHC_COMPILERSRC = $(TOP)/ghc/compiler -GHC_RUNTIMESRC = $(TOP)/ghc/runtime -GHC_LIBSRC = $(TOP)/ghc/lib -GHC_INCLUDESRC = $(TOP)/ghc/includes -GHC_UTILSRC = $(TOP)/ghc/utils -GHC_BOOKSRC = $(TOP)/ghc/book - -GHC_INCLUDES = $(GHC_INCLUDESRC) - -ifeq ($(HaskellCompilerType), HC_CHALMERS_HBC) -GHC_RTS_STYLE = 'hbc' -else -ifeq ($(HaskellCompilerType), HC_ROJEMO_NHC) -GHC_RTS_STYLE = 'ghc' /* wrong, but more likely to trigger something */ -else -GHC_RTS_STYLE = 'ghc' -endif -endif - -PROJECT_GHC_OPTS = -hi-diffs -dcore-lint -link-chk - -GLUED_GHC_OPTS = \ - $(ALL_PROJECTS_GHC_OPTS) \ - $(PLATFORM_GHC_OPTS) \ - $(PROJECT_GHC_OPTS) \ - $(GHC_OPTS) \ - $(EXTRA_GHC_OPTS) - -GHCFLAGS=$(GLUED_CPP_DEFINES) $(GLUED_GHC_OPTS) - -#----------------------------------------------------------------------------- -# What to build - -BuildYorkInterpreter = NO -UseSemantiqueStrictnessAnalyser = NO - -#----------------------------------------------------------------------------- -# Installation: whether to, where to, what to - -AT_GLASGOW = @AT_GLASGOW@ - -ifeq ($(AT_GLASGOW),1) -GHC_DRIVER_INST_NAME = ghc-$(PROJECTVERSION) -else -GHC_DRIVER_INST_NAME = ghc -endif - -# Make sure we install things with group 'grasp' at Glasgow - -ifeq ($(AT_GLASGOW),1) -INSTGROUP = -g grasp -endif - -# At Glasgow, we would rather the installed binaries were stripped. -# (Delete if you feel otherwise.) - -INSTSTRIP = -s - -# Installation directories -------------------------------------------------- - -prefix_GHC = @prefix@ -exec_prefix_GHC = @exec_prefix@ - -ifeq ($(AT_GLASGOW), 1) -INSTBINDIR_GHC = $(exec_prefix_GHC)/bin/`/usr/local/gnu/bin/hw_os` -else -INSTBINDIR_GHC = $(exec_prefix_GHC)/bin -endif - -INSTSCRIPDIR_GHC = $(exec_prefix_GHC)/bin -INSTLIBDIR_GHC = $(prefix_GHC)/lib/ghc/$(PROJECTVERSION)/$(HOSTPLATFORM) -INSTDATADIR_GHC = $(prefix_GHC)/lib/ghc/$(PROJECTVERSION) -INSTIMPORTSDIR_GHC = $(INSTDATADIR_GHC)/imports - -# ----------------------------------------------------------------------------- -# Where to find the programs for the various phases - -GHC = $(GHC_DRIVERSRC)/ghc -GHC_HSCPP = $(GHC_HSCPPSRC)/hscpp $(ALLPROJ_CPP_DEFINES) -GHC_HSCPPSRC = $(GHC_UTILSRC)/hscpp -GHC_HSP = $(GHC_HSPSRC)/hsp -GHC_HSPSRC = $(GHC_HSCSRC) -GHC_HSC = $(GHC_HSCSRC)/hsc -GHC_HSCSRC = $(GHC_COMPILERSRC) -GHC_SYSMAN = $(GHC_RUNTIMESRC)/gum/SysMan -GHC_SYSMANSRC = $(GHC_RUNTIMESRC) - -#----------------------------------------------------------------------------- -# Stuff for the C-compiling phase in particular... - -# NON-OPTIMISING C COMPILATION: ================================= - -ifeq ($(HaveGcc), YES) -GhcUseGccForDebuggingAsm = YES -GHC_DEBUG_HILEV_ASM = $(WhatGccIsCalled) -else -GhcUseGccForDebuggingAsm = NO -GHC_DEBUG_HILEV_ASM = $(CC) -endif - -# OPTIMISING C COMPILATION (regs, etc): ========================== - -ifeq ($(HaveGcc), YES) -GhcUseGccForOptAsm = YES -GHC_OPT_HILEV_ASM = $(WhatGccIsCalled) -GHC_GCC_IS_AVAILABLE = 1 -else -GhcUseGccForOptAsm = NO -GHC_OPT_HILEV_ASM = $(CC) -GHC_GCC_IS_AVAILABLE = 0 -endif - diff --git a/ghc/mk/paths.mk b/ghc/mk/paths.mk new file mode 100644 index 0000000000..d7b30e7ae5 --- /dev/null +++ b/ghc/mk/paths.mk @@ -0,0 +1,78 @@ +# ----------------------------------------------------------------------------- +# +# ghc project specific make variables +# + +# Override default haskell compiler if required +#HC = $(WithGhcHc) +HaskellCompilerType = $(WithGhcHcType) + +# What ways to build the RTS+libs +WAYS=$(GhcLibWays) + + +MKDEPENDHSSRC = $(GHC_UTILS_DIR)/mkdependHS +UNLIT = $(GHC_UNLIT_DIR)/unlit +GHC_UNLIT_DIR = $(GHC_UTILS_DIR)/unlit + +#----------------------------------------------------------------------------- +# HsTags + +ifdef UseInstalledUtils +HSTAGS = hstags +else +HSTAGS = $(HSTAGS_DIR)/hstags +HSTAGS_DIR = $(GHC_UTILS_DIR)/hstags +endif + +#----------------------------------------------------------------------------- +# Ugen + +ifdef UseInstalledUtils +UGEN = ugen +else +UGEN = $(UGEN_DIR)/ugen +UGENSRC = $(GHC_UTILS_DIR)/ugen +endif + +#----------------------------------------------------------------------------- +# Extra things ``only for'' for the ghc project + +GHC_DRIVER_DIR = $(TOP)/driver +GHC_COMPILER_DIR = $(TOP)/compiler +GHC_RUNTIME_DIR = $(TOP)/runtime +GHC_LIB_DIR = $(TOP)/lib +GHC_INCLUDE_DIR = $(TOP)/includes +GHC_UTILS_DIR = $(TOP)/utils + +GHC = $(GHC_DRIVER_DIR)/ghc +GHC_HSCPP_DIR = $(GHC_UTILS_DIR)/hscpp +GHC_HSCPP = $(GHC_HSCPP_DIR)/hscpp +GHC_HSP = $(GHC_HSP_DIR)/hsp +GHC_HSP_DIR = $(GHC_HSC_DIR) +GHC_HSC = $(GHC_HSC_DIR)/hsc +GHC_HSC_DIR = $(GHC_COMPILER_DIR) +GHC_SYSMAN = $(GHC_RUNTIME_DIR)/gum/SysMan +GHC_SYSMAN_DIR = $(GHC_RUNTIME_DIR)/gum + +#----------------------------------------------------------------------------- +# Stuff for the C-compiling phase in particular... + +# NON-OPTIMISING C COMPILATION: ================================= + +ifeq ($(HaveGcc), YES) +GHC_DEBUG_HILEV_ASM = $(WhatGccIsCalled) +else +GHC_DEBUG_HILEV_ASM = $(CC) +endif + +# OPTIMISING C COMPILATION (regs, etc): ========================== + +ifeq ($(HaveGcc), YES) +GHC_OPT_HILEV_ASM = $(WhatGccIsCalled) +GHC_GCC_IS_AVAILABLE = 1 +else +GHC_OPT_HILEV_ASM = $(CC) +GHC_GCC_IS_AVAILABLE = 0 +endif + diff --git a/ghc/mk/site-ghc.mk b/ghc/mk/site-ghc.mk deleted file mode 100644 index eb79afed8f..0000000000 --- a/ghc/mk/site-ghc.mk +++ /dev/null @@ -1,94 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: site-ghc.mk,v 1.4 1996/11/25 14:53:12 simonm Exp $ - -# GHC_BUILD_FLAG_x -# these are alternative flag names that can be given -# to the driver to indicate build x. - -# GHC_BUILD_OPTS_x -# these are lists of flags to be added when the driver -# receives a $(GHC_BUILD_FLAG_x) flag. Only valid for -# user build ways. - -# ================================================================ -# BUILDS stuff: main sequential ones - -# (these aren't used --simonm) - -#GHC_BUILD_FLAG_normal = -#GHC_BUILD_FLAG_p = -#GHC_BUILD_FLAG_t = -#GHC_BUILD_FLAG_u = - -# === builds: concurrent and parallel ============================ - -#GHC_BUILD_FLAG_mc = -#GHC_BUILD_FLAG_mr = -#GHC_BUILD_FLAG_mt = -#GHC_BUILD_FLAG_mp = -#GHC_BUILD_FLAG_mg = - -# === builds: non-std garbage collectors ========================== - -GHC_BUILD_FLAG_2s = -gc-2s -GHC_BUILD_FLAG_1s = -gc-1s -GHC_BUILD_FLAG_du = -gc-du - -# === builds: "user ways" ======================================= - -GHC_BUILD_FLAG_a = -build-a-not-defined -GHC_BUILD_OPTS_a = - -GHC_BUILD_FLAG_b = -build-b-not-defined -GHC_BUILD_OPTS_b = - -GHC_BUILD_FLAG_c = -build-c-not-defined -GHC_BUILD_OPTS_c = - -GHC_BUILD_FLAG_d = -build-d-not-defined -GHC_BUILD_OPTS_d = - -GHC_BUILD_FLAG_e = -build-e-not-defined -GHC_BUILD_OPTS_e = - -GHC_BUILD_FLAG_f = -build-f-not-defined -GHC_BUILD_OPTS_f = - -GHC_BUILD_FLAG_g = -build-g-not-defined -GHC_BUILD_OPTS_g = - -GHC_BUILD_FLAG_h = -build-h-not-defined -GHC_BUILD_OPTS_h = - -GHC_BUILD_FLAG_i = -build-i-not-defined -GHC_BUILD_OPTS_i = - -GHC_BUILD_FLAG_j = -build-j-not-defined -GHC_BUILD_OPTS_j = - -GHC_BUILD_FLAG_k = -build-k-not-defined -GHC_BUILD_OPTS_k = - -GHC_BUILD_FLAG_l = -build-l-not-defined -GHC_BUILD_OPTS_l = - -GHC_BUILD_FLAG_m = -build-m-not-defined -GHC_BUILD_OPTS_m = - -GHC_BUILD_FLAG_n = -build-n-not-defined -GHC_BUILD_OPTS_n = - -GHC_BUILD_FLAG_o = -build-o-not-defined -GHC_BUILD_OPTS_o = - -GHC_BUILD_FLAG_A = -build-A-not-defined -GHC_BUILD_OPTS_A = - -GHC_BUILD_FLAG_B = -build-B-not-defined -GHC_BUILD_OPTS_B = - -# ======= END OF BUILD INFO ==================================== - -# Temp until we reliable bootstrap - -Ghc2_0 = NO diff --git a/ghc/mk/suffix.mk b/ghc/mk/suffix.mk new file mode 100644 index 0000000000..5cec340b11 --- /dev/null +++ b/ghc/mk/suffix.mk @@ -0,0 +1,21 @@ +################################################################################# +# +# $Id: suffix.mk,v 1.1 1997/03/14 08:00:37 simonpj Exp $ +# +# GHC-specific suffix rules +# +################################################################################# + +#----------------------------------------------------------------------------- +# Ugen suffix rules. +# +# Hack, the implicit rule assumes the ugen files +# resides in a directory parser/ +# + +parser/%.h parser/%.c parser/U_%.hs : parser/%.ugn + @$(RM) $@ parser/$*.hs parser/U_$*.hs parser/$*.h + $(UGEN) $< || $(RM) parser/$*.h parser/$*.hs + @$(MV) -f parser/$*.hs parser/U_$*.hs + @chmod 444 parser/$*.h parser/U_$*.hs + diff --git a/ghc/mk/suffixes-ghc.mk b/ghc/mk/suffixes-ghc.mk deleted file mode 100644 index 6965e16a3c..0000000000 --- a/ghc/mk/suffixes-ghc.mk +++ /dev/null @@ -1,40 +0,0 @@ -# ----------------------------------------------------------------------------- -# suffxies-ghc.mk - -# suffix rules needed for compiling bits of ghc. - -# ----------------------------------------------------------------------------- - -ifdef UnlitSuffixRules - -define UnlitSuffixCmds - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ -endef - -.lprl.prl: - $(UnlitSuffixCmds) - -.lh.h: - $(UnlitSuffixCmds) - -.lc.c: - $(UnlitSuffixCmds) - -.lhc.hc: - $(UnlitSuffixCmds) - -endif - -# ----------------------------------------------------------------------------- - -ifdef UgenSuffixRules - -%.h %.c %.U.hs : %.ugn - @$(RM) $@ $*.hs $*.U.hs $*.h - $(UGEN) $< || $(RM) $*.h $@ $*.hs - @$(MV) -f $*.hs $*.U.hs - @chmod 444 $*.h $@ $*.U.hs - -endif diff --git a/ghc/mk/target.mk b/ghc/mk/target.mk new file mode 100644 index 0000000000..0d49585a90 --- /dev/null +++ b/ghc/mk/target.mk @@ -0,0 +1,14 @@ +# +# target.mk project stub +# + +# We need to set TOP to be the TOP that the next level up expects! +# The TOP variable is reset after the inclusion of the fptools +# boilerplate, so we stash TOP away first: +GHC_TOP := $(TOP) +TOP:=$(TOP)/.. + +include $(TOP)/mk/target.mk + +# Reset TOP +TOP:=$(GHC_TOP) diff --git a/ghc/mk/ways.mk b/ghc/mk/ways.mk deleted file mode 100644 index bbeec417c0..0000000000 --- a/ghc/mk/ways.mk +++ /dev/null @@ -1,38 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: ways.mk,v 1.1 1997/01/07 13:16:54 simonm Exp $ - -# Build an object in several different ways, using a subsidiary Makefile. - -# MAKEFILE = The Makefile to invoke for each way -# DESCR = Description of object being built - -ifndef NoWayAllTarget -all :: - @for i in $(WAY_SUFFIXES); do \ - echo; \ - echo =========== Making $(DESCR) for way $$i; \ - echo; \ - $(MAKE) -f $(MAKEFILE) suffix=$$i; \ - done -endif - -ifndef NoWayInstallTarget -install :: - @for i in $(WAY_SUFFIXES); do \ - $(MAKE) -f $(MAKEFILE) suffix=$$i install; \ - done -endif - -ifndef NoWayCleanTarget -clean :: - @for i in $(WAY_SUFFIXES); do \ - $(MAKE) -f $(MAKEFILE) suffix=$$i clean; \ - done -endif - -# We normally only want to make dependencies once - -ifndef NoWayDependTarget -depend :: - @$(MAKE) -f $(MAKEFILE) depend -endif diff --git a/ghc/utils/hstags/prefix.txt b/ghc/utils/hstags/prefix.txt new file mode 100644 index 0000000000..988cf8a36c --- /dev/null +++ b/ghc/utils/hstags/prefix.txt @@ -0,0 +1,9 @@ +# +# hstags - generating a tags file from Haskell source +# +# To use the script on your system, the following variable +# needs to be set (and uncommented), if it hasn't already +# been set above: +# +#$INSTLIBDIR_GHC='/local/fp/lib/ghc'; +# diff --git a/glafp-utils/Makefile b/glafp-utils/Makefile index 24f2b6bed8..67cade6a1d 100644 --- a/glafp-utils/Makefile +++ b/glafp-utils/Makefile @@ -1,15 +1,19 @@ -TOP=.. -include $(TOP)/mk/gen.mk +################################################################################# +# +# glafp-utils/Makefile +# +# Main Makefile for project glafp-utils +# +################################################################################# -# We need to boot msub and mkdependC (in that order), to be sure that -# make depend will succeed in all the other directories. - -SUBDIRS = msub mkdependC fastmake lndir ltx mkdirhier runstdtest +TOP=. +include $(TOP)/mk/boilerplate.mk -boot :: - $(MAKE) -C msub all - $(MAKE) -C mkdependC all - $(MAKE) depend - $(MAKE) all +# We need to write mkdependC first (in that order), to be sure that +# make depend will succeed in all the other directories. +# +# ToDo: remove msub for good +# +SUBDIRS = mkdependC fastmake lndir ltx mkdirhier runstdtest -include $(TOP)/mk/subdir.mk +include $(TOP)/mk/target.mk diff --git a/glafp-utils/fastmake/Makefile b/glafp-utils/fastmake/Makefile index 902012ade0..64ce2a70e0 100644 --- a/glafp-utils/fastmake/Makefile +++ b/glafp-utils/fastmake/Makefile @@ -1,9 +1,19 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +TOP=.. +include $(TOP)/mk/boilerplate.mk + +SCRIPT_PROG=fastmake +SCRIPT_OBJS=fastmake.prl + +# +# Prepend (perl) bindings for these Makefile variables +# when creating the final script +# +SCRIPT_SUBST_VARS=TMPDIR -PROG=fastmake -SRC=fastmake.prl INTERP=$(PERL) +# ToDo: install DESTDIR=$(INSTSCRIPTDIR) +CLEAN_FILES += $(SCRIPT_PROG) + +include $(TOP)/mk/target.mk -include $(TOP)/mk/script.mk diff --git a/glafp-utils/fastmake/fastmake.prl b/glafp-utils/fastmake/fastmake.prl index 730e6a41a5..e314df3e1d 100644 --- a/glafp-utils/fastmake/fastmake.prl +++ b/glafp-utils/fastmake/fastmake.prl @@ -1,4 +1,7 @@ -#! /usr/local/bin/perl +# +# Perl stub requires the following variable to be prepended +# TMPDIR +# # ($Pgm = $0) =~ s/.*\/([^\/]+)$/\1/; $Usage = "\n" . <<EOUSAGE; @@ -34,8 +37,8 @@ $Makefile = 'Makefile'; if ( $ENV{'TMPDIR'} ) { # where to make tmp file names $Tmpfile = $ENV{'TMPDIR'} . "/Makefile$$"; } else { - $Tmpfile = "$(TMPDIR)/Makefile$$"; - $ENV{'TMPDIR'} = '$(TMPDIR)'; # set the env var as well + $Tmpfile = "${TMPDIR}/Makefile$$"; + $ENV{'TMPDIR'} = "${TMPDIR}"; # set the env var as well } $SleazyTouch = '/usr/5bin/touch'; $DoTouch = 0; diff --git a/glafp-utils/lndir/Makefile b/glafp-utils/lndir/Makefile index 3e31171953..d2558c7c61 100644 --- a/glafp-utils/lndir/Makefile +++ b/glafp-utils/lndir/Makefile @@ -1,8 +1,10 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +TOP=.. +include $(TOP)/mk/boilerplate.mk -SRCS=lndir.c -PROG=lndir +C_SRCS=lndir.c +C_PROG=lndir + +CLEAN_FILES += $(C_PROG) $(C_OBJS) DESTDIR=$(INSTBINDIR) -include $(TOP)/mk/Cprog.mk +include $(TOP)/mk/target.mk diff --git a/glafp-utils/ltx/Makefile b/glafp-utils/ltx/Makefile index 08fb2509bb..42a653b8e8 100644 --- a/glafp-utils/ltx/Makefile +++ b/glafp-utils/ltx/Makefile @@ -1,9 +1,12 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +TOP=.. +include $(TOP)/mk/boilerplate.mk + +SCRIPT_PROG=ltx +SCRIPT_OBJS=ltx.prl +SCRIPT_SUBST_VARS=TMPDIR CONTEXT_DIFF -PROG=ltx -SRC=ltx.prl INTERP=$(PERL) -DESTDIR=$(INSTBINDIR) +DESTDIR=$(INSTSCRIPTDIR) +CLEAN_FILES += $(SCRIPT_PROG) -include $(TOP)/mk/script.mk +include $(TOP)/mk/target.mk diff --git a/glafp-utils/ltx/ltx.prl b/glafp-utils/ltx/ltx.prl index bf5c767d08..7504d5510e 100644 --- a/glafp-utils/ltx/ltx.prl +++ b/glafp-utils/ltx/ltx.prl @@ -1,3 +1,10 @@ +# +# The perl script requires bindings for the following +# variables to be prepended: +# TMPDIR +# CONTEXTDIFF +# + $Pgm = $0; $Pgm =~ s/.*\/([^\/]+)$/\1/; # # set up signal handler @@ -30,8 +37,8 @@ if (-f $ARGV[0]) { if ( $ENV{'TMPDIR'} ) { # where to make tmp file names $Tmp_prefix = $ENV{'TMPDIR'} ; } else { - $Tmp_prefix ='$(TMPDIR)'; - $ENV{'TMPDIR'} = '$(TMPDIR)'; # set the env var as well + $Tmp_prefix ="$TMPDIR"; + $ENV{'TMPDIR'} = "$TMPDIR"; # set the env var as well } sub rm_temp_files { @@ -188,7 +195,7 @@ sub something_more_needed { && (system("cmp -s $tmp_pre-.aux-cite.$$ $tmp_pre-.aux-prev-cite.$$") >> 8)) { $BibTeX_run_needed = 1 if $Bibliography_requested; if ($Verbose) { - system("$(CONTEXT_DIFF) $tmp_pre-.aux-prev-cite.$$ $tmp_pre-.aux-cite.$$"); + system("$CONTEXT_DIFF $tmp_pre-.aux-prev-cite.$$ $tmp_pre-.aux-cite.$$"); } } @@ -196,7 +203,7 @@ sub something_more_needed { $MakeIndex_run_needed = (system("cmp -s $TeX_root.idx $TeX_root.idx-prev") >> 8) ? 1 : 0; if ($MakeIndex_run_needed && $Verbose) { - system("$(CONTEXT_DIFF) $TeX_root.idx-prev $TeX_root.idx"); + system("$CONTEXT_DIFF $TeX_root.idx-prev $TeX_root.idx"); } } } diff --git a/glafp-utils/mk/boilerplate.mk b/glafp-utils/mk/boilerplate.mk new file mode 100644 index 0000000000..f2129e56ac --- /dev/null +++ b/glafp-utils/mk/boilerplate.mk @@ -0,0 +1,31 @@ +################################################################################# +# +# GHC boilerplate.mk +# +# Boilerplate Makefile for an fptools project +# +################################################################################# + +# Begin by slurping in the boilerplate from one level up. +# Remember, TOP is the top level of the innermost level +# (FPTOOLS_TOP is the fptools top) + +# We need to set TOP to be the TOP that the next level up expects! +GLAFP_UTILS_TOP := $(TOP) +TOP:=$(GLAFP_UTILS_TOP)/.. + +include $(TOP)/mk/boilerplate.mk + +# ----------------------------------------------------------------- +# Everything after this point +# augments or overrides previously set variables. +# (these files are optional, so `make' won't fret if +# cannot get to them). +# ----------------------------------------------------------------- + +#Not currently used: -include $(GLAFP_UTILS_TOP)/mk/paths.mk +-include $(GLAFP_UTILS_TOP)/mk/opts.mk +#Not currently used: -include $(GLAFP_UTILS_TOP)/mk/suffix.mk + +# No ways, please +WAYS= diff --git a/glafp-utils/mk/opts.mk b/glafp-utils/mk/opts.mk new file mode 100644 index 0000000000..3cbdc9689f --- /dev/null +++ b/glafp-utils/mk/opts.mk @@ -0,0 +1,9 @@ +# +# glafp-utils options +# + +# +# msub'ing with the following +# +MSUB_OPTS += -f Makefile -f $(FPTOOLS_TOP)/mk/config.mk + diff --git a/glafp-utils/mkdependC/Makefile b/glafp-utils/mkdependC/Makefile index f711d77d36..e45b6e0365 100644 --- a/glafp-utils/mkdependC/Makefile +++ b/glafp-utils/mkdependC/Makefile @@ -1,9 +1,21 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +# +# Boilerplate Makefile for building perl script that +# needs some configured constants prepended to it. +# +TOP=.. +include $(TOP)/mk/boilerplate.mk -PROG=mkdependC -SRC=mkdependC.prl +boot :: all + +SCRIPT_PROG=mkdependC +SCRIPT_OBJS=mkdependC.prl +# +# Prepend (perl) bindings for these Makefile variables +# when creating `mkdependC' (a more flexible way of doing msub). +# +SCRIPT_SUBST_VARS=RAWCPP HOSTPLATFORM + +CLEAN_FILES += $(SCRIPT_PROG) INTERP=$(PERL) -DESTDIR=$(INSTBINDIR) -include $(TOP)/mk/script.mk +include $(TOP)/mk/target.mk diff --git a/glafp-utils/mkdependC/mkdependC.prl b/glafp-utils/mkdependC/mkdependC.prl index e81c148234..000b0eb16c 100644 --- a/glafp-utils/mkdependC/mkdependC.prl +++ b/glafp-utils/mkdependC/mkdependC.prl @@ -1,5 +1,9 @@ -# *** MSUB does some substitutions here *** -# *** grep for $( *** +# +# This stub of perl assumes that the following two +# variables are prepended: +# +# RAWCPP +# HOSTPLATFORM # # tries to work like mkdependC # @@ -23,7 +27,7 @@ $Makefile = ''; # the following is a hack, so we can use RAWCPP, but there you go; # put in just enough #defines that mkdependC will not barf. -$HostPlatform = '$(HOSTPLATFORM)'; +$HostPlatform = ${HOSTPLATFORM}; if ( $HostPlatform =~ /^i386-/ ) { push(@Defines, '-D__i386__'); @@ -149,7 +153,7 @@ sub slurp_file { # follows an example in the `open' item in perl man page $fname = &tidy_dir_names($fname); - unless (open($fhandle, "$(RAWCPP) $Include_dirs @Defines $fname |")) { + unless (open($fhandle, "${RAWCPP} $Include_dirs @Defines $fname |")) { die "$Pgm: Can't open $fname: $!\n"; } line: while (<$fhandle>) { diff --git a/glafp-utils/mkdirhier/Makefile b/glafp-utils/mkdirhier/Makefile index 92146a2ca0..8ae4c4a50f 100644 --- a/glafp-utils/mkdirhier/Makefile +++ b/glafp-utils/mkdirhier/Makefile @@ -1,9 +1,12 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +# +# -PROG=mkdirhier -SRC=mkdirhier.sh +TOP=.. +include $(TOP)/mk/boilerplate.mk + +SCRIPT_PROG=mkdirhier +SCRIPT_OBJS=mkdirhier.sh INTERP=$(SHELL) -DESTDIR=$(INSTSCRIPTDIR) +CLEAN_FILES += $(SCRIPT_PROG) -include $(TOP)/mk/script.mk +include $(TOP)/mk/target.mk diff --git a/glafp-utils/msub/Makefile b/glafp-utils/msub/Makefile index 0aeddfa28d..2a0d89ba23 100644 --- a/glafp-utils/msub/Makefile +++ b/glafp-utils/msub/Makefile @@ -1,12 +1,7 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +TOP=.. +include $(TOP)/mk/boilerplate.mk -SRCS=msub.c -PROG=msub -DESTDIR=$(INSTBINDIR) - -# No need for dependencies, which is just as well since -# mkdependC can't be built until msub has been build! -OmitCDepend = YES - -include $(TOP)/mk/Cprog.mk +C_SRCS=msub.c +C_PROG=msub +CLEAN_FILES += $(C_PROG) $(C_OBJS) +include $(TOP)/mk/target.mk diff --git a/glafp-utils/runstdtest/Makefile b/glafp-utils/runstdtest/Makefile index aba1193d8e..1659c97a89 100644 --- a/glafp-utils/runstdtest/Makefile +++ b/glafp-utils/runstdtest/Makefile @@ -1,9 +1,15 @@ -TOP=../.. -include $(TOP)/mk/gen.mk +# +# -PROG=runstdtest -SRC=runstdtest.prl +TOP=.. +include $(TOP)/mk/boilerplate.mk + +SCRIPT_PROG=runstdtest +SCRIPT_OBJS=runstdtest.prl +SCRIPT_SUBST_VARS=RM TMPDIR CONTEXT_DIFF INTERP=$(PERL) -DESTDIR=$(INSTBINDIR) -include $(TOP)/mk/script.mk +CLEAN_FILES += $(SCRIPT_PROG) +DESTDIR=$(INSTSCRIPTDIR) + +include $(TOP)/mk/target.mk diff --git a/glafp-utils/runstdtest/runstdtest.prl b/glafp-utils/runstdtest/runstdtest.prl index af75b693eb..bdc3ebf26e 100644 --- a/glafp-utils/runstdtest/runstdtest.prl +++ b/glafp-utils/runstdtest/runstdtest.prl @@ -1,4 +1,10 @@ -#! /usr/local/bin/perl +# +# The perl script requires the following variables to be bound +# to something meaningful before it will operate correctly: +# +# TMPDIR +# CONTEXT_DIFF +# RM # # Given: # * a program to run (1st arg) @@ -37,8 +43,8 @@ $PgmStdinFile = '/dev/null'; if ( $ENV{'TMPDIR'} ) { # where to make tmp file names $TmpPrefix = $ENV{'TMPDIR'}; } else { - $TmpPrefix ="$(TMPDIR)"; - $ENV{'TMPDIR'} = '$(TMPDIR)'; # set the env var as well + $TmpPrefix ="$TMPDIR"; + $ENV{'TMPDIR'} = "$TMPDIR"; # set the env var as well } $ScriptFile = "$TmpPrefix/run_me$$"; $DefaultStdoutFile = "$TmpPrefix/no_stdout$$"; # can't use /dev/null (e.g. Alphas) @@ -215,7 +221,7 @@ else if [ \$hit = 'NO' ] ; then echo $ToRun @PgmArgs \\< $PgmStdinFile echo expected stdout not matched by reality - $(CONTEXT_DIFF) $PgmStdoutFile[0] $TmpPrefix/runtest$$.1 + ${CONTEXT_DIFF} $PgmStdoutFile[0] $TmpPrefix/runtest$$.1 myexit=1 diffsShown=1 fi @@ -232,7 +238,7 @@ done if [ \$hit = 'NO' ] ; then echo $ToRun @PgmArgs \\< $PgmStdinFile echo expected stderr not matched by reality - $(CONTEXT_DIFF) $PgmStderrFile[0] $TmpPrefix/runtest$$.2 + ${CONTEXT_DIFF} $PgmStderrFile[0] $TmpPrefix/runtest$$.2 myexit=1 diffsShown=1 fi @@ -244,7 +250,7 @@ if [ $SpixTiming = 'yes' -a \$myexit = 0 ] ; then $SpixstatsLine2 fi -$(RM) core $ToRunOrig.spix $DefaultStdoutFile $DefaultStderrFile $TmpPrefix/runtest$$.1 $TmpPrefix/runtest$$.2 $TmpPrefix/runtest$$.3 +${RM} core $ToRunOrig.spix $DefaultStdoutFile $DefaultStderrFile $TmpPrefix/runtest$$.1 $TmpPrefix/runtest$$.2 $TmpPrefix/runtest$$.3 exit \$myexit EOSCRIPT diff --git a/mk/Cprog.mk b/mk/Cprog.mk deleted file mode 100644 index 2d6015603d..0000000000 --- a/mk/Cprog.mk +++ /dev/null @@ -1,42 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: Cprog.mk,v 1.2 1996/11/21 16:50:26 simonm Exp $ - -# Useful variables: - -# PROG = program name -# SRCS = list of sources (optional for one file) -# LIBS = libraries -# DEPLIBS = more libraries (may depend on $(LIBS) -# DESTDIR = where to install -# INSTALLED_NAME = name to install as (default = $(PROG)) - -#----------------------------------------------------------------------------- - -ifndef INSTALLED_NAME -INSTALLED_NAME = $(PROG) -endif - -ifndef SRCS -SRCS = $(PROG).c -endif - -OBJS = $(SRCS:.c=.o) - -all :: $(PROG) - -$(PROG) :: $(OBJS) - $(CC) -o $@ $(CFLAGS) $(LDOPTIONS) $(OBJS) $(DEPLIBS) $(LIBS) - -install :: $(PROG) - $(INSTALL) $(INSTBINFLAGS) $(PROG) $(DESTDIR)/$(INSTALLED_NAME) - -clean :: - $(RM) $(PROG) - -tags :: - $(CTAGS) -a $(CTAGSFLAGS) $(SRCS) - -ifndef OmitCDepend - C_DEP_SRCS = $(SRCS) - include $(TOP)/mk/cdepend.mk -endif diff --git a/mk/HSprog.mk b/mk/HSprog.mk deleted file mode 100644 index 27cb8d1f92..0000000000 --- a/mk/HSprog.mk +++ /dev/null @@ -1,38 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: HSprog.mk,v 1.2 1996/11/21 16:50:28 simonm Exp $ - -# Useful variables: - -# PROG = program name -# SRCS = list of source files -# LIBS = libraries -# DEPLIBS = more libraries (may depend on $(LIBS) -# DESTDIR = where to install -# INSTALLED_NAME = name to install as (default = $(PROG)) - -#----------------------------------------------------------------------------- - -ifndef INSTALLED_NAME -INSTALLED_NAME = $(PROG) -endif - -OBJS = $($(SRCS:.hs.o):.lhs.o) - -all :: $(PROG) - -$(PROG) :: $(OBJS) - $(HC) -o $@ $(HCFLAGS) $(LDOPTIONS) $(OBJS) $(DEPLIBS) $(LIBS) - -install :: $(PROG) - $(INSTALL) $(INSTBINFLAGS) $(PROG) $(DESTDIR)/$(INSTALLED_NAME) - -clean :: - $(RM) $(PROG) - -tags :: $(SRCS) - $(HSTAGS) $(HSTAGSFLAGS) $(SRCS) - -ifndef OmitHSDepend - HS_DEP_SRCS = $(SRCS) - include $(TOP)/mk/hsdepend.mk -endif diff --git a/mk/boilerplate.mk b/mk/boilerplate.mk new file mode 100644 index 0000000000..c8cd897a18 --- /dev/null +++ b/mk/boilerplate.mk @@ -0,0 +1,58 @@ +################################################################################# +# +# mk/boilerplate.mk +# +# The Glorious fptools Boilerplate Makefile +# +# This one file should be included (directly or indirectly) by all Makefiles +# in the fptools hierarchy. +# +################################################################################# + +# We want to disable all the built-in rules that make uses; having them +# just slows things down, and we write all the rules ourselves. +# Setting .SUFFIXES to empty disables them all. +MAKEFLAGS += --no-builtin-rules + +# FPTOOLS_TOP is the *relative* path to the fptools toplevel directory from the +# location where a project Makefile was invoked. It is set by looking at the +# current value of TOP. +# +FPTOOLS_TOP := $(TOP) + + +# This rule makes sure that "all" is the default target, regardless of where it appears +# THIS RULE MUST REMAIN FIRST! +default: all + + + +# Now follow the pieces of boilerplate +# The "-" signs tell make not to complain if they don't exist + +include $(TOP)/mk/config.mk +# All configuration information +# (generated by "configure" from config.mk.in) +# + + +include $(TOP)/mk/paths.mk +# Variables that say where things belong (e.g install directories) +# and where we are right now +# Also defines variables for standard files (SRCS, LIBS etc) + + +include $(TOP)/mk/opts.mk +# Variables that control the option flags for all the +# language processors + +include $(TOP)/mk/suffix.mk +# Suffix rules for Haskell, C and literate + +-include $(TOP)/mk/build.mk +# (Optional) build-specific configuration +# + +-include .depend +# The dependencies file from the current directory + diff --git a/mk/cdepend.mk b/mk/cdepend.mk deleted file mode 100644 index 9915f72b7e..0000000000 --- a/mk/cdepend.mk +++ /dev/null @@ -1,14 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: cdepend.mk,v 1.2 1996/11/21 16:50:30 simonm Exp $ - -# Useful variables: - -# C_DEP_SRCS = C sources for make depend - -#----------------------------------------------------------------------------- - -depend :: $(C_DEP_SRCS) - @$(RM) .depend - @touch .depend - $(MKDEPENDC) $(MKDEPENDCFLAGS) -- $(CFLAGS) -- $(C_DEP_SRCS) - diff --git a/mk/clib.mk b/mk/clib.mk deleted file mode 100644 index 2f91da2378..0000000000 --- a/mk/clib.mk +++ /dev/null @@ -1,34 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: clib.mk,v 1.2 1996/11/21 16:50:31 simonm Exp $ - -# Useful variables: - -# ARCHIVE = archive name -# LIBOBJS = list of object files -# DESTDIR = where to install -# INSTALLED_NAME = name to install as (default = $(ARCHIVE)) -# DEP_SRCS = sources for make depend (optional) - -#----------------------------------------------------------------------------- - -ifndef INSTALLED_NAME -INSTALLED_NAME = $(ARCHIVE) -endif - -all :: $(ARCHIVE) - -$(ARCHIVE) :: $(LIBOBJS) - @$(RM) $@ - $(AR) $@ $(LIBOBJS) - $(RANLIB) $@ - -install :: $(ARCHIVE) - $(INSTALL) $(INSTDATAFLAGS) $(ARCHIVE) $(DESTDIR)/$(INSTALLED_NAME) - cd $(DESTDIR)/$(INSTALLED_NAME); $(RANLIB) $(INSTALLED_NAME) - -clean :: - $(RM) $(ARCHIVE) - -ifdef DEP_SRCS -include $(TOP)/mk/cdepend.mk -endif diff --git a/mk/config.h.in b/mk/config.h.in new file mode 100644 index 0000000000..61354bd3d5 --- /dev/null +++ b/mk/config.h.in @@ -0,0 +1,182 @@ +/* config.h.in. Generated automatically from configure.in by autoheader. */ + +/* Define to empty if the keyword does not work. */ +#undef const + +/* Define as the return type of signal handlers (int or void). */ +#undef RETSIGTYPE + +/* Define if you have the ANSI C header files. */ +#undef STDC_HEADERS + +/* Define if you can safely include both <sys/time.h> and <time.h>. */ +#undef TIME_WITH_SYS_TIME + +/* Define if you have access. */ +#undef HAVE_ACCESS + +/* Define if you have ftime. */ +#undef HAVE_FTIME + +/* Define if you have getclock. */ +#undef HAVE_GETCLOCK + +/* Define if you have getpagesize. */ +#undef HAVE_GETPAGESIZE + +/* Define if you have getrusage. */ +#undef HAVE_GETRUSAGE + +/* Define if you have gettimeofday. */ +#undef HAVE_GETTIMEOFDAY + +/* Define if you have mktime. */ +#undef HAVE_MKTIME + +/* Define if you have mprotect. */ +#undef HAVE_MPROTECT + +/* Define if you have setitimer. */ +#undef HAVE_SETITIMER + +/* Define if you have stat. */ +#undef HAVE_STAT + +/* Define if you have sysconf. */ +#undef HAVE_SYSCONF + +/* Define if you have timelocal. */ +#undef HAVE_TIMELOCAL + +/* Define if you have times. */ +#undef HAVE_TIMES + +/* Define if you have vadvise. */ +#undef HAVE_VADVISE + +/* Define if you have vfork. */ +#undef HAVE_VFORK + +/* Define if you have alloca. */ +#undef HAVE_ALLOCA + +/* Define if you have the <alloca.h> header file. */ +#undef HAVE_ALLOCA_H + +/* Define if you have the <dirent.h> header file. */ +#undef HAVE_DIRENT_H + +/* Define if you have the <fcntl.h> header file. */ +#undef HAVE_FCNTL_H + +/* Define if you have the <grp.h> header file. */ +#undef HAVE_GRP_H + +/* Define if you have the <malloc.h> header file. */ +#undef HAVE_MALLOC_H + +/* Define if you have the <memory.h> header file. */ +#undef HAVE_MEMORY_H + +/* Define if you have the <nlist.h> header file. */ +#undef HAVE_NLIST_H + +/* Define if you have the <pwd.h> header file. */ +#undef HAVE_PWD_H + +/* Define if you have the <siginfo.h> header file. */ +#undef HAVE_SIGINFO_H + +/* Define if you have the <signal.h> header file. */ +#undef HAVE_SIGNAL_H + +/* Define if you have the <sys/socket.h> header file. */ +#undef HAVE_SYS_SOCKET_H + +/* Define if you have the <stdlib.h> header file. */ +#undef HAVE_STDLIB_H + +/* Define if you have the <string.h> header file. */ +#undef HAVE_STRING_H + +/* Define if you have the <sys/fault.h> header file. */ +#undef HAVE_SYS_FAULT_H + +/* Define if you have the <sys/file.h> header file. */ +#undef HAVE_SYS_FILE_H + +/* Define if you have the <sys/file.h> header file. */ +#undef HAVE_SYS_MMAN_H + +/* Define if you have the <sys/param.h> header file. */ +#undef HAVE_SYS_PARAM_H + +/* Define if you have the <sys/procfs.h> header file. */ +#undef HAVE_SYS_PROCFS_H + +/* Define if you have the <sys/resource.h> header file. */ +#undef HAVE_SYS_RESOURCE_H + +/* Define if you have the <sys/signal.h> header file. */ +#undef HAVE_SYS_SIGNAL_H + +/* Define if you have the <sys/stat.h> header file. */ +#undef HAVE_SYS_STAT_H + +/* Define if you have the <sys/syscall.h> header file. */ +#undef HAVE_SYS_SYSCALL_H + +/* Define if you have the <sys/time.h> header file. */ +#undef HAVE_SYS_TIME_H + +/* Define if you have the <sys/timeb.h> header file. */ +#undef HAVE_SYS_TIMEB_H + +/* Define if you have the <sys/timers.h> header file. */ +#undef HAVE_SYS_TIMERS_H + +/* Define if you have the <sys/times.h> header file. */ +#undef HAVE_SYS_TIMES_H + +/* Define if you have the <sys/types.h> header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define if you have the <sys/utsname.h> header file. */ +#undef HAVE_SYS_UTSNAME_H + +/* Define if you have the <sys/vadvise.h> header file. */ +#undef HAVE_SYS_VADVISE_H + +/* Define if you have the <sys/wait.h> header file. */ +#undef HAVE_SYS_WAIT_H + +/* Define if you have the <termios.h> header file. */ +#undef HAVE_TERMIOS_H + +/* Define if you have the <time.h> header file. */ +#undef HAVE_TIME_H + +/* Define if you have the <types.h> header file. */ +#undef HAVE_TYPES_H + +/* Define if you have the <unistd.h> header file. */ +#undef HAVE_UNISTD_H + +/* Define if you have the <utime.h> header file. */ +#undef HAVE_UTIME_H + +/* Define if you have the <vfork.h> header file. */ +#undef HAVE_VFORK_H + +/* Define if you have the fl library (-lfl). */ +#undef HAVE_LIBFL + +/* Define if you have the l library (-ll). */ +#undef HAVE_LIBL + +/* Define if you have tm_zone in struct tm. */ +#undef HAVE_TM_ZONE + +/* Define if you have extern char *tzname[2]. */ +#undef HAVE_TZNAME + diff --git a/mk/config.mk.in b/mk/config.mk.in new file mode 100644 index 0000000000..c8fa245ed7 --- /dev/null +++ b/mk/config.mk.in @@ -0,0 +1,688 @@ +# +# @configure_input@ +# +################################################################################# +# +# config.mk.in-template +# +# This file defines all the variables that set the configuration of +# a particular build. +# +# +################################################################################# + +# The configuration is defined in two steps: +# +# 1. The builder (i.e. the person doing the build) +# copies this file, config.mk.in-template +# to config.mk.in +# +# 2. S/he then edits it manually (gasp) to reflect any configuration +# options s/he wants. +# +# 3. Then s/he runs "configure", which generates config.mk from +# config.mk.in, substituting for system/platform-dependent things +# enclosed in @at-signs@. +# +# This is one of only two files that configure generates (the other is config.h) +# +# Note that after subsequent edits of config.mk.in for a build, the configure script +# will have to be re-run manually to have the change reflected in config.mk. +# + +# There is a section below for each project within the fptools suite +# +# PLUS +# +# a section corresponding to each of the main .mk files +# included by boilerplate.mk (see boilerplate.mk for a list). + + + +################################################################################# +# +# project-wide flags +# +# Set of options applicable to all fptools projects +# +################################################################################# + +# +# What parts to build: An fptools build tree does not have to be built +# all in one go. By setting the list of ProjectsToBuild in build.mk you can +# control which projects are built. +# +# Caution: the projects are built in the order given here, so if some +# projects use others you must list them in the correct order. +# +# Generally: * glafp-utils should be first +# * literate next +# * happy next +# * ghc&hslibs next +# then it's up to you + +ProjectsToBuild = glafp-utils literate ghc hslibs + +# +# Should the various project tests directories be built? +# +IncludeTestDirsInBuild=NO + +################################################################################# +# +# GHC project +# +# Set of (configurable) options needed by the ghc tree +# plus their default options (if any). +# +################################################################################# + +# +# Name variables for ghc: +# +GhcProjectName =The Glorious Glasgow Haskell Compilation System +GhcProjectNameShort =ghc +GhcProjectVersion =2.02 +GhcProjectPatchLevel =0 +GhcBuildeeVersion =202 +GhcBuilderVersion =29 + +# +# Name variables for the fptools, for now equal to the above +# ghc stuff +# +ProjectName =$(GhcProjectName) +ProjectNameShort =$(GhcProjectNameShort) +ProjectVersion =$(GhcProjectVersion) +ProjectPatchLevel =$(GhcProjectPatchLevel) + + +#--------------------------------------------------------------- +# +# Variables that control how the compiler itself is built + +# Specify the Haskell compiler to be used to compile the compiler itself +# WithGhcHc Path name of the compiler to use +# Ghc2_0 Whether this compiler is GHC 2.0 or later +# (which affects gruesome details about +# how mutually recursive modules are handled) +# WithGhcHcType What "type" of compiler is being used +# Valid options: +# HC_CHALMERS_HBC +# HC_GLASGOW_GHC +# HC_ROJEMO_NHC +# HC_UNSPECIFIED +WithGhcHc = ghc-0.29 +Ghc2_0=NO +# Unused, we think +# WithGhcHcType=HC_GLASGOW_GHC + +# Extra ways in which to build the compiler (for example, you might want to +# build a profiled compiler so you can see where it spends its time) +GhcCompilerWays= + +# Extra option flags to pass to the compiler that compiles the compiler +# (Ones that are essential are wired into ghc/compiler/Makefile) +# Typical ones: +# -O compiler an optimised compiler +# -DDEBUG include consistency/assertion checks in the compiled compiler +# -fshow-import-specs show import specialisations +GhcHcOpts= + +# GhcWithHscBuiltViaC - build GHC compiler proper (\`hsc') from .hc files? +GhcWithHscBuiltViaC=NO + +# Build hsc with -O and turn optimising flag on when compiling +# the intermediate C file +GhcUseGccForOptAsm=YES + +# Compile intermediate C file with debugging options set. +GhcUseGccForDebuggingAsm=YES + +# Build a registerised version of hsc and runtime +# (you'd be desperate or silly not to). +GhcWithRegisterised=YES + +# Build a compiler with a native code generator backend +# (as well as a C backend) +# +# Target platforms supported: +# i386, alpha & sparc +GhcWithNativeCodeGen=YES + +# Build the compiler with the deforester included? +GhcWithDeforester=NO + + +#--------------------------------------------------------------- +# +# Variables that control how the prelude libararies and runtime system are built + +# What extra ways to build the libraries in +# In addition to the normal sequential way, the default is to also build +# profiled prelude libraries. +GhcLibWays=p + +# Option flags to pass to GHC when it's compiling prelude modules +# Typically these are things like -O or -dcore-lint +# The ones that are *essential* are wired into ghc/lib/Makefile +GhcLibHcOpts= -split-objs -odir $(basename $*) + + +################################################################################# +# +# hslibs project +# +# Set of (configurable) options needed by the Haskell libraries (hslibs) +# plus their default options (if any). +# +################################################################################# + +# Build the Haskell Readline bindings? +# +HsLibsWithReadline=YES + +# Build the socket libraries? +# +HsLibsWithSockets=YES + +# +# The different ways to build hslibs. Default is just to mirror +# what is done for the ghc prelude libraries. +# +HsLibWays=$(GhcLibWays) + + +################################################################################# +# +# happy project +# +# Happy specific options +# +################################################################################# + + + +################################################################################# +# +# haggis project +# +# Haggis specific options +# +################################################################################# + + + +################################################################################# +# +# green-card project +# +# Green-card specific options +# +################################################################################# + + +################################################################################# +# +# nofib project +# +# nofib specific options +# +################################################################################# + + +# NoFibSubDirs controls which set of tests should be run +# You can run one or more of +# imaginary +# spectral +# real +# parallel +# PRIVATE +# GHC_ONLY +# PENDING +# UNUSED +NoFibSubDirs = imaginary spectral real GHC_ONLY PRIVATE + +# The different ways to build nofib. Default is just to mirror +# what is done for the ghc prelude libraries. +# +NoFibWays=$(GhcLibWays) + +# Haskell compiler options for nofib +NoFibHcOpts= + +# ============================================================================== +# +# END OF PROJECT-SPECIFIC STUFF +# +# Now come the generic configuration options +# +# ============================================================================== + +################################################################################# +# +# Paths (see paths.mk) +# +################################################################################# + +# These variables are all ":=" variables so that you can easily attach +# extra stuff to the end of them, like this: +# +# libdir := $(libdir)/ghc + +TMPDIR := /tmp + +# FPTOOLS_TOP: the top of the fptools hierarchy, absolute path. + +FPTOOLS_TOP_ABS := @hardtop@ + +# +# Installation directories, we don't use half of these, +# but since the configure script has them on offer while +# passing through, we might as well set them. + +prefix := @prefix@ +exec_prefix := @exec_prefix@ +bindir := @bindir@ +sbindir := @sbindir@ +libexecdir := @libexecdir@ +datadir := @datadir@ +sysconfdir := @datadir@ +sharedstatedir := @sharedstatedir@ +localstatedir := @localstatedir@ +libdir := @libdir@ +infodir := @infodir@ +includedir := @includedir@ +oldincludedir := @oldincludedir@ +mandir := @mandir@ +srcdir := @srcdir@ + +################################################################################# +# +# Utilities programs: flags +# +################################################################################# + +# If you want to give any standard flags to pretty much any utility +# (see utils.mk for a complete list), by adding a line here +# +# SRC_P_OPTS += ... +# +# where P is the utility. For example, to add -O to all Haskell +# compilations, +# +# SRC_HC_OPTS += -O + + +################################################################################# +# +# Platform +# +################################################################################# + +# A "platform" is the GNU cpu-type/manufacturer/operating-system target machine +# specifier. E.g. sparc-sun-solaris2 + +HOSTPLATFORM = @HostPlatform@ +TARGETPLATFORM = @TargetPlatform@ +BUILDPLATFORM = @HostPlatform@ + +HostPlatform_CPP = @HostPlatform_CPP@ +HostArch_CPP = @HostArch_CPP@ +HostOS_CPP = @HostOS_CPP@ +HostVendor_CPP = @HostVendor_CPP@ + +# +# ToDo: check if these can be purged now. -- sof +# + +@HostPlatform_CPP@_HOST = 1 +@HostPlatform_CPP@_TARGET = 1 +@HostPlatform_CPP@_BUILD = 1 + +@HostArch_CPP@_HOST_ARCH = 1 +@HostArch_CPP@_TARGET_ARCH = 1 +@HostArch_CPP@_BUILD_ARCH = 1 + +@HostOS_CPP@_HOST_OS = 1 +@HostOS_CPP@_TARGET_OS = 1 +@HostOS_CPP@_BUILD_OS = 1 + +@HostVendor_CPP@_HOST_VENDOR = 1 +@HostVendor_CPP@_TARGET_VENDOR = 1 +@HostVendor_CPP@_BUILD_VENDOR = 1 + +# Leading underscores on symbol names in object files +# Valid options: YES/NO +# +LeadingUnderscore=@LeadingUnderscore@ + +################################################################################# +# +# Utilities programs: where to find them +# +################################################################################# + +#----------------------------------------------------------------------------- +# FPtools Utility locations + +# By default, the various utils needed to be build ghc and chums +# is set up to point to the utils/ directory. Define here the +# path prefix for the utilities. Notice that it's a prefix with +# a trailing slash, so that it can be concatenated directly on +# front of a program name; if it's not set then we just look +# along the shell's $(PATH) +# +# If instead you want to use installed or your own versions of these, +# override the various *_PREFIX in build.mk, i.e., having the following +# in build.mk: +# +# FASTMAKE_PREFIX= +# +# will force `make' to rummage around in your PATH to find `fastmake' (not +# sure it would need it in the first place, but still). +# +GLAFP_UTILS = $(FPTOOLS_TOP)/glafp-utils + +SCRIPT_PREFIX = $(GLAFP_UTILS)/scripts/ +FASTMAKE_PREFIX = $(GLAFP_UTILS)/fastmake/ +MKDEPENDC_PREFIX = $(GLAFP_UTILS)/mkdependC/ +LTX_PREFIX = $(GLAFP_UTILS)/ltx/ +RUNTEST_PREFIX = $(GLAFP_UTILS)/runstdtest/ +VERBATIM_PREFIX = $(GLAFP_UTILS)/verbatim/ +ETAGS_PREFIX = $(GLAFP_UTILS)/etags/ +MSUB_PREFIX = $(GLAFP_UTILS)/msub/ +LNDIR_PREFIX = $(GLAFP_UTILS)/lndir/ +MKDIRHIER_PREFIX = $(GLAFP_UTILS)/mkdirhier/ + +# Still used? +LITERATE = $(FPTOOLS_TOP)/literate + +LITERATE_PREFIX = $(FPTOOLS_TOP)/literate/ +TEXI2HTML_PREFIX = $(LITERATE_PREFIX)texi2html/ + +HAPPY_PREFIX = $(FPTOOLS_TOP)/happy/src/ + +UNLIT_PREFIX = $(FPTOOLS_TOP)/ghc/utils/unlit/ +UGEN_PREFIX = $(FPTOOLS_TOP)/ghc/utils/ugen/ +STAT2RESID_PREFIX = $(FPTOOLS_TOP)/ghc/utils/stat2resid/ +HP2PS_PREFIX = $(FPTOOLS_TOP)/ghc/utils/hp2ps/ +HSCPP_PREFIX = $(FPTOOLS_TOP)/ghc/utils/hscpp/ +HSTAGS_PREFIX = $(FPTOOLS_TOP)/ghc/utils/hstags/ + + +#----------------------------------------------------------------------------- +# Haskell compiler and mkdependHS + +HC = $(FPTOOLS_TOP)/ghc/driver/ghc +MKDEPENDHS = $(HC) + +# +# The compiler proper is built with the 1.2 compiler, +# so when building the dependencies, we need mkdependHS +# for the 1.2 compiler. +# +MKDEPENDHS_1_2 = mkdependHS-1.2 + +#----------------------------------------------------------------------------- +# C compiler +# +# +HaveGcc = @HaveGcc@ +UseGcc = YES +WhatGccIsCalled = gcc +ifeq "$(strip $(HaveGcc))" "YES" +ifneq "$(strip $(UseGcc))" "YES" + CC = cc +else + CC = $(WhatGccIsCalled) +endif +endif + +#----------------------------------------------------------------------------- +# Flex + +FLEX = @LEX@ +FLEX_LIB = @LEXLIB@ + +#----------------------------------------------------------------------------- +# Other standard (ha!) Unix utilities + +AR = @ArCmd@ +# Yuckage: for ghc/utils/parallel -- todo: nuke this dependency!! +BASH = /usr/local/bin/bash +# +# Could be either gzip or compress +# +COMPRESS = @CompressCmd@ +COMPRESS_SUFFIX = @CompressSuffix@ + +CONTEXT_DIFF = @ContextDiffCmd@ +CP = cp +CPP = @RAWCPP@ +CTAGS = $(ETAGS) +RAWCPP = @RAWCPP@ +GNUCPP = @GNUCPP@ +INSTALL = @INSTALL@ +LATEX = latex +LN_S = @LN_S@ +MANMACROS = -man +MSMACROS = -ms +MV = mv +NROFF = nroff +PERL = @PerlCmd@ +PIC = pic +PREPROCESSCMD = $(CC) -E +PRINTER = lpr +RANLIB = @RANLIB@ +RM = rm -f +SED = @SedCmd@ +SHELL = /bin/sh +SIZE = size +STRIP = strip +TAR = @TarCmd@ +# +# This is special to literate/, ToDo: add literate-specific +# configure setup to literate/. +# +TBL = tbl +TEX = tex +TGRIND = tgrind +TGRIND_HELPER = /usr/local/lib/tgrind/tfontedpr # XXX +TIB = tib + +TIME = @TimeCmd@ +TROFF = troff +UNAME = uname +YACC = @YaccCmd@ + + +#----------------------------------------------------------------------------- +# FPtools support software + +# Stuff from fptools/glafp-utils +MKDEPENDC = $(MKDEPENDC_PREFIX)mkdependC +FASTMAKE = $(FASTMAKE_PREFIX)fastmake +LTX = $(LTX_PREFIX)ltx +MKDIRHIER = $(MKDIRHIER_PREFIX)mkdirhier +LNDIR = $(LNDIR_PREFIX)lndir +MSUB = $(MSUB_PREFIX)msub +ETAGS = $(ETAGS_PREFIX)etags +VERBATIM = $(VERBATIM_PREFIX)verbatim +RUNTEST = $(RUNTEST_PREFIX)runstdtest +HAPPY = @HappyCmd@ +LX = @LxCmd@ + +ifneq "$(HAPPY)" "" +HAPPY = $(HAPPY_PREFIX)happy +endif + +# +# Stuff from fptools/literate +# +INFO = $(UTIL_PREFIX)info +MAKEINFO = $(INFO_PREFIX)makeinfo +POSTMAKEINFO = $(INFO_PREFIX)postmakeinfo +LIT2PGM = $(LITERATE_PREFIX)lit2pgm +LIT2TEXI = $(LITERATE_PREFIX)lit2texi +LIT2HTML = $(LITERATE_PREFIX)lit2html +LIT2LATEX = $(LITERATE_PREFIX)lit2latex +MKDEPENDLIT = $(LITERATE_PREFIX)mkdependlit +LIT2CHANGELOG = $(LITERATE_PREFIX)lit2changelog +LIT2TEXT = $(LITERATE_PREFIX)lit2text +TEXI2HTML = $(TEXI2HTML_PREFIX)texi2html + +# +# Stuff from fptools/ghc/utils +# +UNLIT = $(UNLIT_PREFIX)unlit +UGEN = $(UGEN_PREFIX)ugen +STAT2RESID = $(STAT2RESID_PREFIX)stat2resid +HP2PS = $(HP2PS_PREFIX)hp2ps +HSCPP = $(HSCPP_PREFIX)hscpp +HSTAGS = $(HSTAGS_PREFIX)hstags + +# +# Options for the compiling different `ways'. Various projects within +# the glorious fptools tree support building in various user-configured +# ways. For instance, you could set up one `way' such that the prelude +# libraries and hslibs all were built with the option -ffoldr-build-on. +# +# To configure up your own way, have a look at some of the standard ways +# such as profiling, and create your own set of WAY_*_OPTS defs below. +# After having done that, add your way string to WAYS, and after having +# run the configure script, the different projects will add the new way +# to the list of ways they support. +# + +# +# IMPORTANT! The WAYS variable configures the different `ways' +# you want to build a project (or maybe just parts of it, as is +# the case for ghc/). This variable is intended set inside the +# project mk setup, enforcing a global fptools WAYS is a bit too +# much (do you *really* want to build glafp-utils the profiled-concurrent +# way?) +# + +# +# Definitions of the different ways: +# +# * their name: +# - tag, e.g., p +# - description, e.g., profiling +# * what they mean to the driver: +# - WAY_p_HC_OPTS gives the list of command-line options +# to the driver. +# + +# +# The ways currently defined. +# +ALL_WAYS=p t u mc mr mt mp mg 1s 2s du a b c d e f g h i j k l m n o A B + +# +# The following ways currently have treated specially, p u t mc mt my mp mg 1s 2d du, +# as the driver script treats these guys specially and needs to carefully be told +# about the options for these. Hence, we hide the required command line options +# for these in the ghc/driver, as this is the only place they are needed. +# +# If you want to add to these default options, fill in the variables below: +# +WAY_p_NAME=profiling +WAY_p_HC_OPTS= -prof + +# Way t: +WAY_t_NAME=ticky-ticky profiling +WAY_t_HC_OPTS= -ticky + +# Way `u': +WAY_u_NAME=unregisterized (using portable C only) +WAY_u_HC_OPTS= + +# Way `mc': concurrent +WAY_mc_NAME=concurrent +WAY_mc_HC_OPTS=-concurrent + +# Way `mr': +WAY_mr_NAME=profiled concurrent +WAY_mr_HC_OPTS=-prof -concurrent + +# Way `mt': +WAY_mt_NAME=ticky-ticky concurrent +WAY_mt_HC_OPTS=-ticky -concurrent + +# Way `mp': +WAY_mp_NAME=parallel +WAY_mp_HC_OPTS=-parallel + +# +# Way `mg': +# +WAY_mg_NAME=GranSim +WAY_mg_HC_OPTS=-gransim + +# +# Ways for different garbage collectors +# +WAY_2s_NAME=2-space GC +WAY_2s_HC_OPTS=-2s + +WAY_1s_NAME=1-space GC +WAY_1s_HC_OPTS=-1s + +WAY_du_NAME=dual-mode GC +WAY_du_HC_OPTS=-du + +# +# Add user-way configurations here: +# +WAY_A_NAME= +WAY_A_HC_OPTS= + +WAY_B_NAME= +WAY_B_HC_OPTS= + +WAY_a_NAME= +WAY_a_HC_OPTS= + +WAY_b_NAME= +WAY_b_HC_OPTS= + +WAY_c_NAME= +WAY_c_HC_OPTS= + +WAY_d_NAME= +WAY_d_HC_OPTS= + +WAY_e_NAME= +WAY_e_HC_OPTS= + +WAY_f_NAME= +WAY_f_HC_OPTS= + +WAY_g_NAME= +WAY_g_HC_OPTS= + +WAY_h_NAME= +WAY_h_HC_OPTS= + +WAY_i_NAME= +WAY_i_HC_OPTS= + +WAY_j_NAME= +WAY_j_HC_OPTS= + +WAY_k_NAME= +WAY_k_HC_OPTS= + +WAY_l_NAME= +WAY_l_HC_OPTS= + +WAY_m_NAME= +WAY_m_HC_OPTS= + +WAY_n_NAME= +WAY_n_HC_OPTS= + +WAY_o_NAME= +WAY_o_HC_OPTS= diff --git a/mk/gen.mk b/mk/gen.mk deleted file mode 100644 index 95ba44dbba..0000000000 --- a/mk/gen.mk +++ /dev/null @@ -1,37 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: gen.mk,v 1.2 1996/11/21 16:50:32 simonm Exp $ - -# General include file for the top of a Makefile. - -# So `all' is the default target... - -all :: - @: - -include $(TOP)/mk/platform.mk -include $(TOP)/mk/utils.mk -include $(TOP)/mk/rules.mk -include $(TOP)/mk/install.mk - -# fastmake omits the dependencies - -ifndef FAST --include .depend -endif - -whoami:: - @echo $(PROJECTNAME), version $(PROJECTVERSION) $(PROJECTPATCHLEVEL) - @echo project\: $(PROJECTLABEL)\; setup\: $(SETUPLABEL) - @echo now building on a \`$(BUILDPLATFORM)\' host - @echo hoping to run on a \`$(HOSTPLATFORM)\' host - -clean:: - $(RM) $(FilesToClean) \#* - -veryclean:: - $(RM) $(FilesToClean) $(ExtraFilesToBeVeryClean) \#* - -tags:: - $(RM) TAGS; touch TAGS - -depend:: diff --git a/mk/hsdepend.mk b/mk/hsdepend.mk deleted file mode 100644 index 0e5d388ebf..0000000000 --- a/mk/hsdepend.mk +++ /dev/null @@ -1,14 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: hsdepend.mk,v 1.2 1996/11/21 16:50:33 simonm Exp $ - -# Useful variables: - -# HS_DEP_SRCS = C sources for make depend - -#----------------------------------------------------------------------------- - -depend :: $(HS_DEP_SRCS) - @$(RM) .depend - @touch .depend - $(MKDEPENDHS) $(MKDEPENDHSFLAGS) -- $(HCFLAGS) -- $(HS_DEP_SRCS) - diff --git a/mk/install.mk.in b/mk/install.mk.in deleted file mode 100644 index 2d45807648..0000000000 --- a/mk/install.mk.in +++ /dev/null @@ -1,83 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: install.mk.in,v 1.2 1996/11/21 16:50:34 simonm Exp $ - -AT_GLASGOW = @AT_GLASGOW@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -ifeq ($(AT_GLASGOW), 1) -INSTBINDIR = $(exec_prefix)/bin/`/usr/local/gnu/bin/hw_os` -else -INSTBINDIR = $(exec_prefix)/bin -endif - -INSTSCRIPTDIR = $(exec_prefix)/bin -INSTLIBDIR = $(prefix)/lib/$(HOSTPLATFORM) -INSTDATADIR = $(prefix)/lib - -#----------------------------------------------------------------------------- -# Man pages & Documentation - -# top of manual page tree to install in -# NB: not necessarily the same place as to look for man pages (?) -INSTMANROOT = $(prefix) - -# prefix for man page _sources_ (vs .../cat) -INSTMANSRCROOT = $(INSTMANROOT)/man - -# man pages for commands -INSTCOMMANDIR = $(INSTMANSRCROOT)$(COMMANSUFFIX) - -# man pages for library routines -INSTLIBMANDIR = $(INSTMANSRCROOT)$(LIBMANSUFFIX) - -# man pages for system commands -INSTSYSMANDIR = $(INSTMANSRCROOT)$(SYSMANSUFFIX) - -# suffix for installing commands'/etcs' man pages -COMMANSUFFIX = 1 -LIBMANSUFFIX = 3 -SYSMANSUFFIX = 8 - -ifeq ($(AT_GLASGOW), 1) -INSTINFODIR = /local/doc/info -else -INSTINFODIR = $(prefix)/info -endif - -#----------------------------------------------------------------------------- -# How to install things - -# this stuff about "who" does the installing doesn't have make vars -# as it is not intended to be runtime-changeable. -# -ifdef OWNER -INSTOWNER = -o $(OWNER) -else -INSTOWNER = -endif - -ifdef GROUP -INSTGROUP = -g $(GROUP) -else -INSTGROUP = -endif - -INSTFILEFLAGS = -INSTSTRIP = -INSTBINFLAGS = \ - -m 0755 $(INSTOWNER) $(INSTGROUP) $(INSTFILEFLAGS) $(INSTSTRIP) - - -# No strip flags on rest of these -- avoids message from install -# about stripping non-binaries. - -GENINSTALLFLAGS = $(INSTOWNER) $(INSTGROUP) $(INSTFILEFLAGS) - -INSTSCRIPTFLAGS = -m 0755 $(GENINSTALLFLAGS) -INSTLIBFLAGS = -m 0644 $(GENINSTALLFLAGS) -INSTDATALIBFLAGS = -m 0644 $(GENINSTALLFLAGS) -INSTINCFLAGS = -m 0644 $(GENINSTALLFLAGS) -INSTDATAFLAGS = -m 0644 $(GENINSTALLFLAGS) -INSTMANFLAGS = -m 0644 $(GENINSTALLFLAGS) -INSTRANLIBFLAGS = diff --git a/mk/lib.mk b/mk/lib.mk deleted file mode 100644 index 653c26021b..0000000000 --- a/mk/lib.mk +++ /dev/null @@ -1,40 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: lib.mk,v 1.3 1997/01/07 13:14:36 simonm Exp $ - -# Useful variables: - -# ARCHIVE = archive name -# LIBOBJS = list of object files -# DESTDIR = where to install -# INSTALLED_NAME = name to install as (default = $(ARCHIVE)) -# C_DEP_SRCS = sources for C make depend (optional) -# HS_DEP_SRCS = sources for Haskell make depend (optional) - -#----------------------------------------------------------------------------- - -ifndef INSTALLED_NAME -INSTALLED_NAME = $(ARCHIVE) -endif - -all :: $(ARCHIVE) - -$(ARCHIVE) :: $(LIBOBJS) - @$(RM) $@ - $(AR) $@ $(LIBOBJS) - $(RANLIB) $@ - -install :: $(ARCHIVE) - $(INSTALL) $(INSTLIBFLAGS) $(ARCHIVE) $(DESTDIR)/$(INSTALLED_NAME) - cd $(DESTDIR); $(RANLIB) $(INSTALLED_NAME) - -clean :: - $(RM) $(LIBOBJS) - $(RM) $(ARCHIVE) - -ifdef C_DEP_SRCS -include $(TOP)/mk/cdepend.mk -endif - -ifdef HS_DEP_SRCS -include $(TOP)/mk/hsdepend.mk -endif diff --git a/mk/opts.mk b/mk/opts.mk new file mode 100644 index 0000000000..863bcdd559 --- /dev/null +++ b/mk/opts.mk @@ -0,0 +1,115 @@ +################################################################################# +# +# opts.mk +# +# This file defines Make variables for the +# option flags for each utility program +# +# $Id: opts.mk,v 1.1 1997/03/14 08:02:27 simonpj Exp $ +# +################################################################################# + +# Exports: Define P_OPTS for the most important utility programs, P, namely +# +# AR AS CPP CTAGS C FLEX HC HSTAGS LD LINT +# LIT2CHANGELOG LIT2HTML LIT2LATEX LIT2PGM LIT2TEXI +# MKDEPENDC MKDEPENDHS MKDEPENDLIT MSUB +# RUNTEST UGEN UNLIT YACC + + +# For each such utility program P, this file defines +# +# $(P) The pathname to invoke the utility +# P_OPTS Options to pass to P +# +# P_OPTS is always defined like this: +# +# P_OPTS = SRC_P_OPTS WAY$(_way)_P_OPTS BUILD_P_OPTS EXTRA_P_OPTS +# +# where the variables on the right hand side are set by the user or +# some other Makefile. They have the following intended uses: +# +# SRC_P_OPTS Source-tree options for P +# WAY$(_way)_P_OPTS Source-tree options for P specific to $(way) +# BUILD_P_OPTS Build-tree options for P +# EXTRA_P_OPTS Command-line options for P +# +# All these options should be set with +# thing += extra-options +# in case someone higher up the include hierarchy has already added some + + +################################################################################# +# +# Global option flags for utilities +# +################################################################################# + +# These flags make flex 8-bit +SRC_FLEX_OPTS += -s -8 + +# +# Make sure we install things with group 'grasp' at Glasgow +# At Glasgow, we would rather the installed binaries were stripped. +# (Delete if you feel otherwise.) +SRC_INSTALL_OPTS += -s +ifeq ($(AT_GLASGOW),1) +SRC_INSTALL_OPTS += -g grasp +endif + +# lint gets all CPP's flags too +SRC_LINT_OPTS += -axz -DLINT $(SRC_CPP_OPTS) +WAY$(_way)_LINT_OPTS += WAY$(_way)_CPP_OPTS + + +# Default fptools options for texi2html: +# +# - each node in separate file. +# - handle texi menus and glossaries. +# +# +SRC_TEXI2HTML_OPTS +=-menu -verbose -glossary + + +################################################################################# +# +# Absolutely standard glue +# +################################################################################# + +# All the standard gluing together, as in the comment right at the front + + +# For the Haskell compiler and runtests we do something a bit special: +# we also include target-specific flags +HC_OPTS = $(SRC_HC_OPTS) $(WAY$(_way)_HC_OPTS) $($*_HC_OPTS) $(EXTRA_HC_OPTS) + +RUNTEST_OPTS = $(SRC_RUNTEST_OPTS) $(WAY$(_way)_RUNTEST_OPTS) \ + $($*_RUNTEST_OPTS) $(EXTRA_RUNTEST_OPTS) + +AR_OPTS = $(SRC_AR_OPTS) $(WAY$(_way)_AR_OPTS) $(EXTRA_AR_OPTS) +AS_OPTS = $(SRC_AS_OPTS) $(WAY$(_way)_AS_OPTS) $(EXTRA_AS_OPTS) +CPP_OPTS = $(SRC_CPP_OPTS) $(WAY$(_way)_CPP_OPTS) $(EXTRA_CPP_OPTS) +CTAGS_OPTS = $(SRC_CTAGS_OPTS) $(WAY$(_way)_CTAGS_OPTS) $(EXTRA_CTAGS_OPTS) +CC_OPTS = $(SRC_CC_OPTS) $(WAY$(_way)_CC_OPTS) $($*_CC_OPTS) $(EXTRA_CC_OPTS) +FLEX_OPTS = $(SRC_FLEX_OPTS) $(WAY$(_way)_FLEX_OPTS) $(EXTRA_FLEX_OPTS) +HAPPY_OPTS = $(SRC_HAPPY_OPTS) $(WAY$(_way)_HAPPY_OPTS) $($*_HAPPY_OPTS) $(EXTRA_HAPPY_OPTS) +HSTAGS_OPTS = $(SRC_HSTAGS_OPTS) $(WAY$(_way)_HSTAGS_OPTS) $(EXTRA_HSTAGS_OPTS) +INSTALL_OPTS = $(SRC_INSTALL_OPTS) $(WAY$(_way)_INSTALL_OPTS) $(EXTRA_INSTALL_OPTS) +LD_OPTS = $(SRC_LD_OPTS) $(WAY$(_way)_LD_OPTS) $(EXTRA_LD_OPTS) +LINT_OPTS = $(SRC_LINT_OPTS) $(WAY$(_way)_LINT_OPTS) $(EXTRA_LINT_OPTS) +LIT2CHANGELOG_OPTS = $(SRC_LIT2CHANGELOG_OPTS) $(WAY$(_way)_LIT2CHANGELOG_OPTS) \ + $(EXTRA_LIT2CHANGELOG_OPTS) +LIT2HTML_OPTS = $(SRC_LIT2HTML_OPTS) $(WAY$(_way)_LIT2HTML_OPTS) $(EXTRA_LIT2HTML_OPTS) +LIT2LATEX_OPTS = $(SRC_LIT2LATEX_OPTS) $(WAY$(_way)_LIT2LATEX_OPTS) $(EXTRA_LIT2LATEX_OPTS) +LIT2PGM_OPTS = $(SRC_LIT2PGM_OPTS) $(WAY$(_way)_LIT2PGM_OPTS) $(EXTRA_LIT2PGM_OPTS) +LIT2TEXI_OPTS = $(SRC_LIT2TEXI_OPTS) $(WAY$(_way)_LIT2TEXI_OPTS) $(EXTRA_LIT2TEXI_OPTS) +TEXI2HTML_OPTS = $(SRC_TEXI2HTML_OPTS) $(WAY$(_way)_TEXI2HTML_OPTS) $(EXTRA_TEXI2HTML_OPTS) +MKDEPENDC_OPTS = $(SRC_MKDEPENDC_OPTS) $(WAY$(_way)_MKDEPENDC_OPTS) $(EXTRA_MKDEPENDC_OPTS) +MKDEPENDHS_OPTS = $(SRC_MKDEPENDHS_OPTS) $(WAY$(_way)_MKDEPENDHS_OPTS) \ + $(EXTRA_MKDEPENDHS_OPTS) +MKDEPENDLIT_OPTS = $(SRC_MKDEPENDLIT_OPTS) $(WAY$(_way)_MKDEPENDLIT_OPTS) \ + $(EXTRA_MKDEPENDLIT_OPTS) +UGEN_OPTS = $(SRC_UGEN_OPTS) $(WAY$(_way)_UGEN_OPTS) $(EXTRA_UGEN_OPTS) +UNLIT_OPTS = $(SRC_UNLIT_OPTS) $(WAY$(_way)_UNLIT_OPTS) $(EXTRA_UNLIT_OPTS) +YACC_OPTS = $(SRC_YACC_OPTS) $(WAY$(_way)_YACC_OPTS) $(EXTRA_YACC_OPTS) diff --git a/mk/paths.mk b/mk/paths.mk new file mode 100644 index 0000000000..fed38d2738 --- /dev/null +++ b/mk/paths.mk @@ -0,0 +1,274 @@ +################################################################################# +# +# paths.mk +# +# This file defines Make variables for standard directories +# and file lists +# +################################################################################# + + +#----------------------------------------------------------------- +# +# Installation setup +# + +#----------------------------------------------------------------------------- +# install configuration +# +# The install standard target is guided by the following four variables +# +# INSTALL_PROGS (installed in $(bindir)) +# INSTALL_LIBS (installed in $(libdir)) +# INSTALL_LIBEXECS (installed in $(libexecdir)) +# INSTALL_DATAS (installed in $(datadir)) +# +# see target.mk for more information. +# + +# +# Setting user/group ownership for the installed entities +# +# this stuff about "who" does the installing doesn't have make vars +# as it is not intended to be run-time changeable. +# +ifneq "$(OWNER)" "" +INSTALL_OWNER = -o $(OWNER) +else +INSTALL_OWNER = +endif + +ifneq "$(GROUP)" "" +INSTALL_GROUP = -g $(GROUP) +else +INSTALL_GROUP = +endif + +SRC_INSTALL_OPTS += $(INSTALL_OWNER) $(INSTALL_GROUP) + +# +# Invocations of `install' for the three different classes +# of targets: +# + +INSTALL_PROGRAM = $(INSTALL) +INSTALL_DATA = $(INSTALL) -m 644 +INSTALL_DIR = $(FPTOOLS_TOP)/glafp-utils/mkdirhier/mkdirhier + +# +# The install variables does not have any defaults, +# what files to install have to be specified in the Makefiles. +# +#INSTALL_PROGS += $(HS_PROG) $(C_PROG) +#INSTALL_LIBS += $(LIBRARY) +#INSTALL_DATAS += $(HS_IFACES) + +#----------------------------------------------------------------------------- +# Man pages & Documentation +# +# (AFAIK, not currently used) +# + +#man1dir = $(mandir)/man1 +#manext = '.1' +#man1ext = '.1' +#man2dir = $(mandir)/man2 +#man2ext = '.2' +#man3dir = $(mandir)/man3 +#man3ext = '.3' +#man4dir = $(mandir)/man4 +#man4ext = '.4' +#man5dir = $(mandir)/man5 +#man5ext = '.5' +#man6dir = $(mandir)/man6 +#man6ext = '.6' +#man7dir = $(mandir)/man7 +#man7ext = '.7' +#man8dir = $(mandir)/man8 +#man8ext = '.8' + +## top of manual page tree to install in +## NB: not necessarily the same place as to look for man pages (?) +#INSTALL_MAN_ROOT = $(mandir) + +## prefix for man page _sources_ (vs .../cat) +#INSTALL_MAN_SRCROOT = $(INSTALL_MAN_ROOT)/man + +## man pages for commands +#INSTALL_COMMAND_DIR = $(INSTALL_MAN_SRCROOT)$(COMMANSUFFIX) + +## man pages for library routines +#INSTALL_LIB_MANDIR = $(INSTALL_MAN_SRCROOT)$(LIBMANSUFFIX) + +## man pages for system commands +#INSTALL_SYS_MANDIR = $(INSTALL_MAN_SRCROOT)$(SYSMANSUFFIX) + +## suffix for installing commands'/etcs' man pages +#COMMANSUFFIX = 1 +#LIBMANSUFFIX = 3 +#SYSMANSUFFIX = 8 + +INSTALL_INFO_DIR = $(infodir) + + +INSTALL_FILE_OPTS = +INSTALL_STRIP = +INSTALL_BIN_OPTS = \ + -m 0755 $(INSTALL_OWNER) $(INSTALL_GROUP) $(INSTALL_FILE_FLAGS) $(INSTALL_STRIP) + + + + + +################################################################################# +# +# Standard variable names +# +################################################################################# + +# +# The fptools mk setup defines a set of standard names which are used by the standard +# targets provided by mk. One example of this is the use of standard names +# for specifying what files to compile, their intermediate/object code, and +# the name of the final executable. Based on the settings of these variables, the +# standard targets will generate/expand rules that automatically compile and +# link your program. +# +# The general rules: +# +# SRCS - sources, might be prefixed to indicate what type of source +# they are. +# OBJS - object files (possibly prefixed). +# +# PROG - name of final executable +# +# +# +# BOOT_SRCS: list of machine generated Haskell modules. +# HS_SRCS: list of Haskell modules you want to compile. +# (also use by depend rule). +# HS_OBJS: list of corresponding object files +# HS_PROG: program that is ultimately linked. +# HS_IFACES: list of interface files generated +# (caveat: assuming no funny use of -hisuf and that +# file name and module name match) + +SRCS=$(wildcard *.lhs *.hs *.c *.lc *.prl *.lprl *.lit *.verb) + +HS_SRCS=$(filter %.lhs %.hs %.hc,$(SRCS))$(BOOT_SRCS) +HS_OBJS=$(addsuffix .$(way_)o,$(basename $(HS_SRCS))) +HS_IFACES=$(addsuffix .$(way_)hi,$(basename $(HS_SRCS))) + +C_SRCS=$(filter %.lc %.c,$(SRCS)) +C_OBJS=$(addsuffix .$(way_)o,$(basename $(C_SRCS))) + +# SCRIPT_SRCS: list of raw script files (in literate form) +# SCRIPT_OBJS: de-litted scripts +SCRIPT_SRCS=$(filter %.lprl,$(SRCS)) +SCRIPT_OBJS=$(addsuffix .prl,$(basename $(SCRIPT_SRCS))) + +OBJS=$(HS_OBJS) $(C_OBJS) $(SCRIPT_OBJS) + +# +# Note that as long as you use the standard variables for setting +# which C & Haskell programs you want to work on, you don't have +# to set any of the clean variables - the default should do the Right +# Thing. +# + +#------------------------------------------------------------------ +# Clean file make-variables. +# +# The following three variables are used to control +# what gets removed when doing `make clean' +# +# MOSTLYCLEAN_FILES object code etc., but not stuff +# that is slow to recompile and/or stable +# +# CLEAN_FILES all files that are created by running make. +# +# MAINTAINER_CLEAN_FILES also clean out machine-generated files +# that may require extra tools to create. +# +# +MOSTLY_CLEAN_FILES += $(HS_OBJS) $(C_OBJS) +CLEAN_FILES += $(HS_PROG) $(C_PROG) $(SCRIPT_PROG) $(PROG) $(LIBRARY) \ + $(HS_IFACES) \ + a.out core +MAINTAINER_CLEAN_FILES += .depend $(BOOT_SRCS) + +# +# `Standard' set of files to clean out. +# +MOSTLY_CLEAN_FILES += \ + *.CKP *.ln *.BAK *.bak *.o core a.out errs ,* *.a .emacs_* \ + tags TAGS *.ind *.ilg *.idx *.idx-prev *.aux *.aux-prev *.dvi *.log \ + *.toc *.lot *.lof *.blg *.info *.itxi *.itex *.ihtml *.cb + +#------------------------------------------------------------------ +# Documentation setup. +# +# Documentation is not normally produced via the default target, but +# selectively through a set of standard targets (e.g, dvi, html, etc., see +# target.mk). Here we define the variables (and their default settings), +# that control the operation of these standard targets. +# +# Documentation variables: +# +# DOC_SRCS = list of documents you want to generate various +# forms of documentation from. +# DOC_DVI = list of DVI files to generate. +# DOC_HTML = list of HTML files to generate +# DOC_TEXI = list of TexInfo files to generate +# DOC_TEXT = list of simple text files to generate +# +DOC_SRCS=$(wildcard *.tex *.lit) +DOC_DVI =$(addsuffix .dvi,$(basename $(DOC_SRCS))) +DOC_PS =$(addsuffix .ps,$(basename $(DOC_SRCS))) +DOC_TEXI=$(addsuffix .texi,$(basename $(DOC_SRCS))) +DOC_HTML=$(addsuffix .html,$(basename $(DOC_SRCS))) +DOC_TEXT=$(addsuffix .txt,$(basename $(DOC_SRCS))) + +CLEAN_FILES += $(DOC_TEXT) $(DOC_HTML) $(DOC_TEXI) $(DOC_PS) $(DOC_DVI) + +#------------------------------------------------------------------ +# +# Distribution setup +# +# Following variables are used for creating source and binary distributions: +# +# SRC_DIST_NAME && BIN_DIST_NAME -- the package names +# +# SRC_DIST_FILES = list of extra files to include from a build tree into a source +# distribution +# +# SRC_DIST_DIR = what the current directory in the source/build tree +# maps to in the source distrib. tree being created. +# +SRC_DIST_NAME=$(ProjectNameShort)-$(ProjectVersion) + +# +# Binary distributions proceeds as follows: +# +# Fromthe top of a build tree, you do `make binary-dist'. The +# canned rule for this (in target.mk) will then do a binary +# install to a temporary directory before packaging it all up. +# The following variables guide the binary-dist: +# +# BIN_DIST_TMPDIR= the absolute path to where the temporary directory +# structure of a binary distribution should be created. +# [Default: toplevel from which you issue `make binary-dist'] +# BIN_DIST_NAME= what to call the thing. +# +# BIN_DIST_DIRS= at the toplevel, list of directories to descend into when +# building the distribution tree. +# +# An extra directory variable that is set during bin-dists is $(bindist_top), giving +# the abs. path to the root of the binary installation tree. (useful when punting +# stuff like README and ANNOUNCE into a distrib, for instance) +# +# The layout of a binary distribution is described in the +# installation documentation. +# + + diff --git a/mk/platform.mk.in b/mk/platform.mk.in deleted file mode 100644 index bf32042624..0000000000 --- a/mk/platform.mk.in +++ /dev/null @@ -1,22 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: platform.mk.in,v 1.2 1996/11/21 16:50:36 simonm Exp $ - -HOSTPLATFORM = @HostPlatform@ -TARGETPLATFORM = @HostPlatform@ -BUILDPLATFORM = @HostPlatform@ - -@HostPlatform_CPP@_HOST = 1 -@HostPlatform_CPP@_TARGET = 1 -@HostPlatform_CPP@_BUILD = 1 - -@HostArch_CPP@_HOST_ARCH = 1 -@HostArch_CPP@_TARGET_ARCH = 1 -@HostArch_CPP@_BUILD_ARCH = 1 - -@HostOS_CPP@_HOST_OS = 1 -@HostOS_CPP@_TARGET_OS = 1 -@HostOS_CPP@_BUILD_OS = 1 - -@HostVendor_CPP@_HOST_VENDOR = 1 -@HostVendor_CPP@_TARGET_VENDOR = 1 -@HostVendor_CPP@_BUILD_VENDOR = 1 diff --git a/mk/rules.mk b/mk/rules.mk deleted file mode 100644 index 46b4c7862d..0000000000 --- a/mk/rules.mk +++ /dev/null @@ -1,319 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: rules.mk,v 1.3 1997/01/21 10:55:01 sof Exp $ - -# This file defines the default suffix rules. It replaces suffixes.jm in the -# jmake system. - -.SUFFIXES: .xdvi .ps .dvi .tex .fig .tib .verb .itex .itxi .ihtml .lit \ - .p_o .o .s .hi .hc .lhc .lhs .hs .prl .lprl .sh .lsh \ - .c .lc .h .lh .flex .lflex .y - -ifndef SuffixRules_WantStdOnes -SuffixRules_WantStdOnes = YES /* but you can turn it off */ -endif - -#----------------------------------------------------------------------------- -# Doc processing suffix rules - -ifdef DocProcessingSuffixRules - -.tex.dvi: - @$(RM) $@ - $(LTX) $< - -.verb.tex: - @$(RM) $*.tex - expand $*.verb | $(VERBATIM) > $*.tex - -.tib.tex: - @$(RM) $*.tex $*.verb-t.tex - $(TIB) $*.tib - expand $*.tib-t.tex | $(VERBATIM) > $*.tex - @$(RM) $*.tib-t.tex - -.fig.ps: - @$(RM) $@ - fig2dev -L ps $< $@ - -.fig.tex: - @$(RM) $@ - fig2dev -L latex $< $@ - -endif - -#----------------------------------------------------------------------------- -# Literate suffix rules - -# ToDo: somehow macroize this lot. - -ifdef LiterateSuffixRules - -.lit: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lit.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lit.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lit.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lhs.hs: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lhs.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lhs.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lhs.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lhc.hc: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lhc.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lhc.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lhc.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lprl.prl: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lprl.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lprl.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lprl.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lsh.sh: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lsh.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lsh.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lsh.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lc.c: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lc.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lc.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lc.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lh.h: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lh.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lh.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lh.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -.lflex.flex: - @$(RM) $@ - $(LIT2PGM) $(LIT2PGMFLAGS) -o $@ $< - @chmod 444 $@ - -.lflex.itxi: - @$(RM) $@ - $(LIT2TEXI) -c $(LIT2TEXIFLAGS) -o $@ $< - @chmod 444 $@ - -.lflex.ihtml: - @$(RM) $@ - $(LIT2HTML) -c $(LIT2HTMLFLAGS) -o $@ $< - @chmod 444 $@ - -.lflex.itex: - @$(RM) $@ - $(LIT2LATEX) -c $(LIT2LATEXFLAGS) -o $@ $< - @chmod 444 $@ - -endif - -#----------------------------------------------------------------------------- -# C-related suffix rules - -ifdef CSuffixRules - -.s.o: - @$(RM) $@ - $(AS) $(ASFLAGS) -o $@ $< || ( $(RM) $@ && exit 1 ) - -.c.o: - @$(RM) $@ - $(CC) $(CFLAGS) -c $< -o $@ - -.c.s: - @$(RM) $@ - $(CC) $(CFLAGS) -S $< -o $@ - -endif - -ifdef FlexSuffixRules - -.flex.c: - @$(RM) $@ - $(FLEX) -t $(LFLAGS) $< > $@ || ( $(RM) $@ && exit 1 ) - -endif - -#----------------------------------------------------------------------------- -# Yacc stuff - -ifdef YaccSuffixRules - -%.tab.c %.tab.h : %.y - @$(RM) $*.tab.h $*.tab.c y.tab.c y.tab.h y.output - $(YACC) $(YFLAGS) $< - $(MV) y.tab.c $*.tab.c - @chmod 444 $*.tab.c - $(MV) y.tab.h $*.tab.h - @chmod 444 $*.tab.h - -endif - -#----------------------------------------------------------------------------- -# Haskell Suffix Rules - -# ToDo: these don't do the .hi-file games for hbc etc. - -ifdef HaskellSuffixRules -SuffixRule_o_hi = YES -SuffixRule_lhs_o = YES -SuffixRule_hs_o = YES -endif - -ifdef SuffixRule_lhs_o -%.o : %.hs - $(HC) $(HCFLAGS) $($*_flags) -c $< -o $@ -endif - -ifdef SuffixRule_hs_o -%.o : %.lhs - $(HC) $(HCFLAGS) $($*_flags) -c $< -o $@ -endif - -ifdef SuffixRule_lhs_hc -%.hc : %.lhs - $(HC) $(HCFLAGS) $($*_flags) -C $< -o $@ -endif - -ifdef SuffixRule_hc_o -%.o : %.hc - $(HC) $(HCFLAGS) $($*_flags) -c $< -o $@ -endif - -ifdef SuffixRule_o_hi -%.hi : %.o - @if [ ! -f $@ ] ; then \ - echo You need to create an initial $@ by hand ; \ - exit 1; \ - else exit 0 ; \ - fi -%.$(suffix)_hi : %.$(suffix)_o - @if [ ! -f $@ ] ; then \ - echo You need to create an initial $@ by hand ; \ - exit 1; \ - else exit 0 ; \ - fi -endif - -ifdef SuffixRule_hc_hi -%.hi : %.hc - @if [ ! -f $@ ] ; then \ - echo You need to create an initial $@ by hand ; \ - exit 1; \ - else exit 0 ; \ - fi -endif - -#----------------------------------------------------------------------------- -# Runtest rules for calling $(GHC) on a single-file Haskell program - -ifdef GhcRunTestRules - -%.runtest : %.hs - $(TIME) $(RUNSTDTEST) $(GHC) $(RUNSTDTEST_FLAGS) \ - -o2 $*.stderr $($*_flags) $< - -endif diff --git a/mk/script.mk b/mk/script.mk deleted file mode 100644 index d06c422397..0000000000 --- a/mk/script.mk +++ /dev/null @@ -1,53 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: script.mk,v 1.2 1996/11/21 16:50:39 simonm Exp $ - -# Useful variables: - -# PROG = program name -# DEPLIST = (optional) dependencies -# SRC = source file -# INTERP = (optional) interpretter -# DESTDIR = where to install -# INSTALLED_NAME = (optional) name to install as - -#----------------------------------------------------------------------------- - -ifndef INSTALLED_NAME -INSTALLED_NAME = $(PROG) -endif - -all :: $(PROG) - -# Hack alert! Since the variables msub needs aren't in the immediate -# Makefile, we must include the relevant files directly. - -MSUB_OPTS = -f Makefile -f $(TOP)/mk/platform.mk -f $(TOP)/mk/utils.mk - -$(PROG) :: $(SRC) $(DEPLIST) - $(RM) $@ -ifdef INTERP - echo "#!"$(INTERP) > $@ -endif - $(MSUB) $(MSUBFLAGS) INSTALLING=0 $(SRC) >> $@ \ - || ( $(RM) $@ && exit 1 ) - chmod a+x $@ - -# aaargh: scripts sometimes do different things depending on whether they -# are installed versions or not (eg. use installed programs rather than -# those in the source tree) hence the following hack: - -install :: $(PROG)_tmp - $(INSTALL) $(INSTSCRIPTFLAGS) $(PROG)_tmp $(DESTDIR)/$(INSTALLED_NAME) - $(RM) $(PROG)_tmp - -$(PROG)_tmp : $(SRC) - $(RM) $@ -ifdef INTERP - echo "#!"$(INTERP) > $@ -endif - $(MSUB) $(MSUBFLAGS) INSTALLING=1 $(SRC) >> $@ \ - || ( $(RM) $@ && exit 1 ) - chmod a+x $@ - -clean :: - $(RM) $(PROG) $(PROG)_tmp diff --git a/mk/subdir.mk b/mk/subdir.mk deleted file mode 100644 index 9d749bc075..0000000000 --- a/mk/subdir.mk +++ /dev/null @@ -1,101 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: subdir.mk,v 1.3 1996/11/22 13:23:23 simonm Exp $ - -# Rules for passing on make commands to sub-directories - -# Useful Variables to set - -# SUBDIRS = subdirectories to recurse into - -# NoAllTargetForSubdirs ] -# NoDocsTargetForSubdirs ] -# NoInstallTargetForSubdirs ] -# NoInstallDocsTargetForSubdirs ] omit specified rules -# NoDependTargetForSubdirs ] -# NoCleanTargetForSubdirs ] -# NoVeryCleanTargetForSubdirs ] - -#----------------------------------------------------------------------------- -# The rules... - -ifndef NoAllTargetForSubdirs -all:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) all; \ - done -endif - -ifndef NoDocsTargetForSubdirs -docs:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) docs; \ - done -else -docs:: -endif - -ifndef NoRunTestsTargetForSubdirs -runtests:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) runtests; \ - done -else -runtests:: -endif - -ifndef NoInstallTargetForSubdirs -install:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) prefix='$(prefix)' install; \ - done -else -install:: -endif - -ifndef NoInstallDocsTargetForSubdirs -install_docs:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) prefix='$(prefix)' install_docs; \ - done -else -install_docs:: -endif - -ifndef NoDependTargetForSubdirs -depend:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) depend; \ - done -else -depend:: -endif - -ifndef NoTagTargetForSubdirs -tags:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) tags; \ - done -endif - -ifndef NoCleanTargetForSubdirs -clean:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) clean; \ - done -endif - -ifndef NoVeryCleanTargetForSubdirs -veryclean:: - @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i $(MFLAGS) veryclean; \ - done -endif diff --git a/mk/suffix.mk b/mk/suffix.mk new file mode 100644 index 0000000000..afe9f6c3c1 --- /dev/null +++ b/mk/suffix.mk @@ -0,0 +1,365 @@ +################################################################################# +# +# suffix.mk +# +# Suffix rules for fptools +# +################################################################################# + +# +# This file contain the default suffix rules for all the fptools projects. +# + + +# No need to define .SUFFIXES because we don't use any suffix rules +# Instead we use gmake's pattern rules exlusively + +.SUFFIXES: + +# However, if $(way) is set then we have to define $(way_) and $(_way) +# from it in the obvious fashion. +# This must be done here (or earlier), but not in target.mk with the other +# way management, because the pattern rules in this file take a snapshot of +# the value of $(way_) and $(_way), and it's no good setting them later! + +ifneq "$(way)" "" + way_ := $(way)_ + _way := _$(way) +endif + +#----------------------------------------------------------------------------- +# Haskell Suffix Rules + +HASKELL_SPLIT_PRE= \ + if [ ! -d $(basename $@) ]; then mkdir $(basename $@) ; else exit 0; fi; \ + find $(basename $@) -name '*.$(way_)o' -print | xargs $(RM) __rm_food; +HASKELL_SPLIT_POST= touch $@ +HASKELL_PRE_COMPILE=$(patsubst %,$(HASKELL_SPLIT_PRE),$(filter -split-objs,$(HC_OPTS))) +HASKELL_POST_COMPILE=$(patsubst %,$(HASKELL_SPLIT_POST),$(filter -split-objs,$(HC_OPTS))) + +%.$(way_)o : %.hs + $(RM) $@ + $(HASKELL_PRE_COMPILE) + $(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@)) + $(HASKELL_POST_COMPILE) + +%.$(way_)o : %.lhs + $(RM) $@ + $(HASKELL_PRE_COMPILE) + $(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@)) + $(HASKELL_POST_COMPILE) + +%.$(way_)hc : %.lhs + $(RM) $@ + $(HC) $(HC_OPTS) -C $< -o $@ + +%.$(way_)o : %.$(way_)hc + $(RM) $@ + $(HASKELL_PRE_COMPILE) + $(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@)) + $(HASKELL_POST_COMPILE) + +%.$(way_)hc : %.lhc + @$(RM) $@ + $(UNLIT) $< $@ + @chmod 444 $@ + + +# Here's an interesting rule! +# The .hi file depends on the .o file, +# so if the .hi file is dated earlier than the .o file (commonly the case, +# when interfaces are stable) this rule just makes sure that the .o file, +# is up to date. Then it does nothing to generate the .hi file from the +# .o file, because the act of making sure the .o file is up to date also +# updates the .hi file (if necessary). + +%.$(way_)hi : %.$(way_)o + @if [ ! -f $@ ] ; then \ + echo Panic! $< exists, but $@ does not. \ + exit 1; \ + else exit 0 ; \ + fi + +%.$(way_)hi : %.$(way_)hc + @if [ ! -f $@ ] ; then \ + echo Panic! $< exists, but $@ does not. \ + exit 1; \ + else exit 0 ; \ + fi + +#----------------------------------------------------------------------------- +# Happy Suffix Rules +# +.PRECIOUS: %.hs + +%.hs : %.ly + $(HAPPY) $(HAPPY_OPTS) -g $< + +#----------------------------------------------------------------------------- +# Lx Suffix Rules +# +.PRECIOUS: %.hs + +%.hs : %.lx + $(LX) $(LX_OPTS) $< + +#----------------------------------------------------------------------------- +# C-related suffix rules + +%.$(way_)o : %.$(way_)s + @$(RM) $@ + $(AS) $(AS_OPTS) -o $@ $< || ( $(RM) $@ && exit 1 ) + +%.$(way_)o : %.c + @$(RM) $@ + $(CC) $(CC_OPTS) -c $< -o $@ + +#%.$(way_)s : %.c +# @$(RM) $@ +# $(CC) $(CC_OPTS) -S $< -o $@ + +%.c : %.flex + @$(RM) $@ + $(FLEX) -t $(FLEX_OPTS) $< > $@ || ( $(RM) $@ && exit 1 ) + +#----------------------------------------------------------------------------- +# Yacc stuff + +%.tab.c %.tab.h : %.y + @$(RM) $*.tab.h $*.tab.c y.tab.c y.tab.h y.output + $(YACC) $(YACC_OPTS) $< + $(MV) y.tab.c $*.tab.c + @chmod 444 $*.tab.c + $(MV) y.tab.h $*.tab.h + @chmod 444 $*.tab.h + + +#----------------------------------------------------------------------------- +# Runtest rules for calling $(HC) on a single-file Haskell program + +%.hs : %.runtest + $(TIME) $(RUNTEST) $(HC) $(RUNTEST_FLAGS) -o2 $*.stderr $< + + +#----------------------------------------------------------------------------- +# Doc processing suffix rules + +%.dvi : %.tex + @$(RM) $@ + $(LTX) $< + +%.ps : %.dvi + @$(RM) $@ + dvips $< -o $@ + +%.tex : %.verb + @$(RM) $*.tex + expand $*.verb | $(VERBATIM) > $*.tex + +%.tex : %.tib + @$(RM) $*.tex $*.verb-t.tex + $(TIB) $*.tib + expand $*.tib-t.tex | $(VERBATIM) > $*.tex + @$(RM) $*.tib-t.tex + +%.ps : %.fig + @$(RM) $@ + fig2dev -L ps $< $@ + +%.tex : %.fig + @$(RM) $@ + fig2dev -L latex $< $@ + +#----------------------------------------------------------------------------- +# Literate suffix rules + +# ToDo: somehow macroize this lot. (if only!) + +%.itxi : %.lit + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.txt : %.lit + @$(RM) $@ + $(LIT2TEXT) -c $(LIT2TEXT_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lit + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lit + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +# +# Produce stand-alone TEX documents +# +%.tex : %.itex + @$(RM) $@ + $(LIT2LATEX) -S $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.tex : %.lhs + @$(RM) $@ + $(LIT2LATEX) -S $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.texi : %.lhs + @$(RM) $@ + $(LIT2TEXI) -S $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.html : %.lhs + @$(RM) $@ + $(LIT2TEXI) $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.texi,$@) $< + $(TEXI2HTML) $(TEXI2HTML_OPTS) $(patsubst %.lhs,%.texi,$<) + @touch $@ + +%.hs : %.lhs + @$(RM) $@ + $(LIT2PGM) $(LIT2PGM_OPTS) -o $@ $< + @chmod 444 $@ + +%.itxi : %.lhs + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lhs + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lhs + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.tex : %.lhs + $(LIT2LATEX) -S -c $(LIT2LATEX_OPTS) -o $@ $< + $(HC) $(HC_OPTS) -c $< -o $@ + + +%.itxi : %.lhc + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lhc + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lhc + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +# +# Temporary, until either unlit is lifted out of ghc/ +# or literate is properly set up locally -- SOF +# +%.prl : %.lprl + @$(RM) $@ + $(UNLIT) $(UNLIT_OPTS) $< $@ + @chmod 444 $@ + +%.itxi : %.lprl + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lprl + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lprl + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.sh : %.lsh + @$(RM) $@ + $(LIT2PGM) $(LIT2PGM_OPTS) -o $@ $< + @chmod 444 $@ + +%.itxi : %.lsh + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lsh + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lsh + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.c : %.lc + @$(RM) $@ + $(UNLIT) $< $@ + @chmod 444 $@ + +%.itxi : %.lc + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lc + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lc + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.h : %.lh + @$(RM) $@ + $(UNLIT) $< $@ + @chmod 444 $@ + +%.itxi : %.lh + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lh + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lh + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + +%.flex : %.lflex + @$(RM) $@ + $(LIT2PGM) $(LIT2PGM_OPTS) -o $@ $< + @chmod 444 $@ + +%.itxi : %.lflex + @$(RM) $@ + $(LIT2TEXI) -c $(LIT2TEXI_OPTS) -o $@ $< + @chmod 444 $@ + +%.ihtml : %.lflex + @$(RM) $@ + $(LIT2HTML) -c $(LIT2HTML_OPTS) -o $@ $< + @chmod 444 $@ + +%.itex : %.lflex + @$(RM) $@ + $(LIT2LATEX) -c $(LIT2LATEX_OPTS) -o $@ $< + @chmod 444 $@ + diff --git a/mk/target.mk b/mk/target.mk new file mode 100644 index 0000000000..28b3d7ce7f --- /dev/null +++ b/mk/target.mk @@ -0,0 +1,873 @@ +################################################################################# +# +# target.mk +# +# Standard targets for fptools +# +################################################################################# + +# +# This file contain three groups of target rules: +# +# 1. FPtools targets +# depend* +# runtests* +# +# 2. GNU standard targets +# all* +# install* uninstall installcheck installdirs +# clean* distclean* mostlyclean* maintainer-clean* +# tags* +# info dvi ps +# dist binary-dist +# check +# +# 3. Some of the above targets have a version that +# recursively invokes that target in sub-directories. +# This relies on the importing Makefile setting SUBDIRS +# +# The recursive targets are marked with a * above +# + +# +# +# + + +################################################################## +# FPtools standard targets +# +# depend: +# +# The depend target has to cope with a set of files that may have +# different ways of computing their dependencies, i.e., a Haskell +# module's dependencies are computed differently from C files. +# +# Note that we don't compute dependencies automatically, i.e., have the +# .depend file be a target that is dependent on the Haskell+C sources, +# and then have the `depend' target depend on `.depend'. The reason for +# this is that when GNU make is processing the `include .depend' statement +# it records .depend as being a Makefile. Before doing any other processing, +# `make' will try to check to see if the Makefiles are up-to-date. And, +# surprisingly enough, .depend has a rule for it, so if any of the source +# files change, it will be invoked, *regardless* of what target you're making. +# +# So, for now, the dependencies has to be re-computed manually via `make depend' +# whenever a module changes its set of imports. Doing what was outlined above +# is only a small optimisation anyway, it would avoid the recomputation of +# dependencies if the .depend file was newer than any of the source modules. +# +.PHONY: depend + +depend :: $(HS_SRCS) $(C_SRCS) + @$(RM) .depend + @touch .depend +ifneq "$(DOC_SRCS)" "" + $(MKDEPENDLIT) -o .depend $(MKDEPENDLIT_OPTS) $(filter %.lit,$(DOC_SRCS)) +endif +ifneq "$(C_SRCS)" "" + $(MKDEPENDC) -f .depend $(MKDEPENDC_OPTS) -- $(CC_OPTS) -- $(C_SRCS) $(MKDEPENDC_SRCS) +endif +ifneq "$(HS_SRCS)" "" +ifeq ($(notdir $(MKDEPENDHS)),ghc) +# New way of doing dependencies: the ghc driver knows how + $(MKDEPENDHS) -M -optdep-f -optdep.depend \ + $(foreach way,$(WAYS),-optdep-s -optdep$(way)) \ + $(MKDEPENDHS_OPTS) \ + $(HC_OPTS) \ + $(HS_SRCS) +else +# Old way: call mkdependHS-1.2 + $(MKDEPENDHS) -f .depend $(MKDEPENDHS_OPTS) \ + $(foreach way,$(WAYS),-s $(way)) \ + -- $(HC_OPTS) -- $(HS_SRCS) $(MKDEPENDHS_SRCS) +endif +endif + + +################################################################## +# boot +# +# The boot target, at a minimum generates dependency information + +.PHONY: boot +boot :: depend + + +################################################################## +# GNU Standard targets +# +# Every Makefile should define the following targets +# +# `all' +# Compile the entire program. This should be the default target. +# This target need not rebuild any documentation files; Info files +# should normally be included in the distribution, and DVI files +# should be made only when explicitly asked for. +# +# `install' +# Compile the program and copy the executables, libraries, and so on +# to the file names where they should reside for actual use. If +# there is a simple test to verify that a program is properly +# installed, this target should run that test. +# +# The commands should create all the directories in which files are +# to be installed, if they don't already exist. This includes the +# directories specified as the values of the variables prefix and +# exec_prefix , as well as all subdirectories that are needed. One +# way to do this is by means of an installdirs target as described +# below. +# +# Use `-' before any command for installing a man page, so that make +# will ignore any errors. This is in case there are systems that +# don't have the Unix man page documentation system installed. +# +# The way to install Info files is to copy them into `$(infodir)' +# with $(INSTALL_DATA) (see Command Variables), and then run the +# install-info program if it is present. install-info is a script +# that edits the Info `dir' file to add or update the menu entry for +# the given Info file; it will be part of the Texinfo package. Here +# is a sample rule to install an Info file: +# +# $(infodir)/foo.info: foo.info # There may be a newer info +# file in . than in srcdir. +# -if test -f foo.info; then d=.; \ +# else d=$(srcdir); fi; \ $(INSTALL_DATA) +# $$d/foo.info $@; \ # Run install-info only if it +# exists. # Use `if' instead of just prepending `-' to the +# # line so we notice real errors from install-info. # We +# use `$(SHELL) -c' because some shells do not # fail +# gracefully when there is an unknown command. +# if $(SHELL) -c 'install-info --version' \ +# >/dev/null 2>&1; then \ install-info +# --infodir=$(infodir) $$d/foo.info; \ else true; +# fi +# +# `uninstall' +# Delete all the installed files that the `install' target would +# create (but not the noninstalled files such as `make all' would +# create). +# +# `clean' +# +# Delete all files from the current directory that are normally +# created by building the program. Don't delete the files that +# record the configuration. Also preserve files that could be made +# by building, but normally aren't because the distribution comes +# with them. +# +# Delete `.dvi' files here if they are not part of the +# distribution. +# +# `distclean' +# Delete all files from the current directory that are created by +# configuring or building the program. If you have unpacked the +# source and built the program without creating any other files, +# `make distclean' should leave only the files that were in the +# distribution. +# +# `mostlyclean' +# Like `clean', but may refrain from deleting a few files that +# people normally don't want to recompile. For example, the +# `mostlyclean' target for GCC does not delete `libgcc.a', because +# recompiling it is rarely necessary and takes a lot of time. +# +# `maintainer-clean' +# Delete everything from the current directory that can be +# reconstructed with this Makefile. This typically includes +# everything deleted by distclean , plus more: C source files +# produced by Bison, tags tables, Info files, and so on. +# +# One exception, however: `make maintainer-clean' should not delete +# `configure' even if `configure' can be remade using a rule in the +# Makefile. More generally, `make maintainer-clean' should not delete +# anything that needs to exist in order to run `configure' and then +# begin to build the program. +# +# `TAGS' +# Update a tags table for this program. +# +# `info' +# Generate any Info files needed. The best way to write the rules is +# as follows: +# +# info: foo.info +# +# foo.info: foo.texi chap1.texi chap2.texi +# $(MAKEINFO) $(srcdir)/foo.texi +# +# You must define the variable MAKEINFO in the Makefile. It should +# run the makeinfo program, which is part of the Texinfo +# distribution. +# +# `dvi' `ps' +# Generate DVI files for all TeXinfo documentation. For example: +# +# dvi: foo.dvi +# +# foo.dvi: foo.texi chap1.texi chap2.texi +# $(TEXI2DVI) $(srcdir)/foo.texi +# +# You must define the variable TEXI2DVI in the Makefile. It should +# run the program texi2dvi , which is part of the Texinfo +# distribution. Alternatively, write just the dependencies, and +# allow GNU Make to provide the command. +# +# ps is a FPtools addition for Postscript files +# +# `dist' `binary-dist' +# Create a distribution tar file for this program. The tar file +# should be set up so that the file names in the tar file start with +# a subdirectory name which is the name of the package it is a +# distribution for. This name can include the version number. +# +# For example, the distribution tar file of GCC version 1.40 unpacks +# into a subdirectory named `gcc-1.40'. +# +# The easiest way to do this is to create a subdirectory +# appropriately named, use ln or cp to install the proper files in +# it, and then tar that subdirectory. +# +# The dist target should explicitly depend on all non-source files +# that are in the distribution, to make sure they are up to date in +# the distribution. See Making Releases. +# +# binary-dist is an FPtools addition for binary distributions +# +# `check' +# Perform self-tests (if any). The user must build the program +# before running the tests, but need not install the program; you +# should write the self-tests so that they work when the program is +# built but not installed. +# +# The following targets are suggested as conventional names, for programs +# in which they are useful. +# +# installcheck +# Perform installation tests (if any). The user must build and +# install the program before running the tests. You should not +# assume that `$(bindir)' is in the search path. +# +# installdirs +# It's useful to add a target named `installdirs' to create the +# directories where files are installed, and their parent +# directories. There is a script called `mkinstalldirs' which is +# convenient for this; find it in the Texinfo package. +# (FPTOOLS: we don't use the suggested script, but rather the +# mkdirhier script in glafp_utils -- SOF) + + + + +########################################### +# +# Targets: "all" +# +########################################### + +# For each of these variables that is defined +# we generate one "all" rule and one rule for the variable itself: +# +# HS_PROG Haskell program +# C_PROG C program +# LIBRARY Library +# SCRIPT_PROG Script (e.g. Perl script) +# +# For details of exactly what rule is generated, see the +# relevant section below + +.PHONY: all + +#---------------------------------------- +# Haskell programs + +ifneq "$(HS_PROG)" "" +all :: $(HS_PROG) + +$(HS_PROG) :: $(HS_OBJS) + $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(HS_OBJS) $(LIBS) +endif + +#---------------------------------------- +# C programs + +ifneq "$(C_PROG)" "" +all :: $(C_PROG) + +$(C_PROG) :: $(C_OBJS) + $(CC) -o $@ $(CC_OPTS) $(LD_OPTS) $(C_OBJS) $(LIBS) +endif + + +#---------------------------------------- +# Libraries/archives + +ifneq "$(LIBRARY)" "" +all :: $(LIBRARY) + + +define BUILD_LIB +$(RM) $@ +$(AR) $(AR_OPTS) $@ $(LIBOBJS) +$(RANLIB) $@ +endef + +# +# For Haskell object files, we might have chosen to split +# up the object files. Test for whether the library being +# built is consisting of Haskell files by (hackily) checking +# whether HS_SRCS is empty or not. +# + +ifneq "$(HS_SRCS)" "" +ifneq "$(filter -split-objs,$(HC_OPTS))" "" +define BUILD_LIB +$(RM) $@ +TMPDIR=$(TMPDIR); export TMPDIR; find $(patsubst %.$(way_)o,%,$(LIBOBJS)) -name '*.$(way_)o' -print | xargs ar q $@ +$(RANLIB) $@ +endef +endif # $(filter... +endif + +$(LIBRARY) :: $(LIBOBJS) + $(BUILD_LIB) +endif + +#---------------------------------------- +# Script programs + +ifneq "$(SCRIPT_PROG)" "" + +# To produce a fully functional script, you may +# have to add some configuration variables at the top of +# the script, i.e., the compiler driver needs to know +# the path to various utils in the build tree for instance. +# +# To have the build rule for the script automatically do this +# for you, set the variable SCRIPT_SUBST_VARS to the list of +# variables you need to put in. + +# +# SCRIPT_SUBST creates a string of echo commands that +# will when evaluated append the (perl)variable name and its value +# to the target it is used for, i.e., +# +# A=foo +# B=bar +# SCRIPT_SUBST_VARS = A B +# SCRIPT_SUBST=echo "$""A=\"foo\";" >> $@; echo "$""B=\"bar\";" >> $@ +# +# so if you have a rule like the following +# +# foo: +# @(RM) $@ +# @(TOUCH) $@ +# @eval $(SCRIPT_SUBST) +# +# `make foo' would create a file `foo' containing the following +# +# % cat foo +# $A=foo; +# $B=bar; +# % +# +# ToDo: make this work for shell scripts (drop the initial $). +# +SCRIPT_SUBST=$(foreach val,$(SCRIPT_SUBST_VARS),"echo \"$$\"\"$(val)=\\\"$($(val))\\\";\" >> $@;") + +all :: $(SCRIPT_PROG) + +$(SCRIPT_PROG) :: $(SCRIPT_OBJS) + $(RM) $@ + @echo Creating $@... +ifneq "$(INTERP)" "" + @echo "#!"$(INTERP) > $@ +else + @touch $@ +endif +ifneq "$(SCRIPT_PREFIX_FILES)" "" + @cat $(SCRIPT_PREFIX_FILES) >> $@ +endif + @eval $(SCRIPT_SUBST) + @cat $(SCRIPT_OBJS) >> $@ + @chmod a+x $@ +endif + + +########################################### +# +# Targets: install install-strip uninstall +# +########################################### + +# For each of these variables that is defined, you +# get one install rule +# +# INSTALL_PROGS install these executable programs in $(bindir) +# INSTALL_LIBS install these platform-dependent libraries in $(libdir) +# INSTALL_LIBEXECS install these platform-dependent execs in $(libdir) +# INSTALL_DATAS install these platform-independent files in $(datadir) +# +# If the installation directory variable is undefined, the install rule simply +# emits a suitable error message. +# +# Remember, too, that the installation directory variables ($(bindir) and +# friends can be overridden from their original settings in mk/config.mk.in +# || mk/build.mk +# +.PHONY: install installdirs install-strip install-dirs uninstall install-docs + +# +# Sometimes useful to separate out the creation of install directories +# from the installation itself. +# +installdirs :: + $(INSTALL_DIR) $(bindir) + $(INSTALL_DIR) $(libdir) + $(INSTALL_DIR) $(libexecdir) + $(INSTALL_DIR) $(datadir) + +# Better do this first... +install:: installdirs + +ifneq "$(INSTALL_PROGS)" "" +install:: $(INSTALL_PROGS) + $(INSTALL_PROGRAM) $(INSTALL_OPTS) $(INSTALL_PROGS) $(bindir) +endif + +ifneq "$(INSTALL_LIBS)" "" +install:: $(INSTALL_LIBS) + $(INSTALL_DATA) $(INSTALL_OPTS) $(INSTALL_LIBS) $(libdir) +endif + +ifneq "$(INSTALL_LIBEXECS)" "" +install:: $(INSTALL_LIBEXECS) + $(INSTALL_PROGRAM) $(INSTALL_OPTS) $(INSTALL_LIBEXECS) $(libexecdir) +endif + +ifneq "$(INSTALL_DATAS)" "" +install:: $(INSTALL_DATAS) + $(INSTALL_DATA) $(INSTALL_OPTS) $(INSTALL_DATAS) $(datadir) +endif + +# +# Use with care.. +# +uninstall:: +ifeq ($(INSTALL_PROGS),) + @for i in $(INSTALL_PROGS) ; do \ + echo rm -f $(bindir)/`basename $$i`; \ + rm -f $(bindir)/`basename $$i`; \ + done +endif +ifeq ($(INSTALL_LIBS),) + @for i in $(INSTALL_LIBS); do \ + echo rm -f $(libdir)/`basename $$i`; \ + rm -f $(libdir)/`basename $$i`; \ + done +endif +ifeq ($(INSTALL_LIBEXECS),) + @for i in $(INSTALL_LIBEXECS); do \ + echo rm -f $(libexecdir)/`basename $$i`; \ + rm -f $(libexecdir)/`basename $$i`; \ + done +endif +ifeq ($(INSTALL_DATAS),) + @for i in $(INSTALL_DATAS); do \ + echo rm -f $(datadir)/`basename $$i`; \ + rm -f $(datadir)/`basename $$i`; \ + done +endif + +# +# install-strip is from the GNU Makefile standard. +# +ifneq "$(way)" "" +install-strip:: + @$(MAKE) EXTRA_INSTALL_OPTS='-s' install +endif + +########################################### +# +# Targets: dist binary-dist +# +########################################### + + +# +# dist-pre is a canned rule the toplevel of your source tree +# would use as follows, +# +# dist :: dist-pre +# +# it performs two tasks, first creating the distribution directory +# tree and it then decorates the new tree with symbolic links pointing +# to the symbolic links in the build tree. +# +# The dist-pre relies on (at least) the `find' in GNU findutils +# (only tested with version 4.1). All non-GNU `find's I have +# laid on my hands locally, has a restrictive treatment of {} in +# -exec commands, i.e., +# +# find . -print echo a{} \; +# +# does not expand the {}, it has to be a separate argument (i.e. `a {}'). +# GNU find is (IMHO) more sensible here, expanding any {} it comes across +# inside an -exec, whether it is a separate argument or part of a word: +# +# $ touch yes +# $ find --version +# GNU find version 4.1 +# $ find yes -exec echo oh,{}! \; +# oh,yes! +# +# I'm not claiming that the above is not possible to achieve with +# other finds, just that GNU find does the Patently Right Thing here :) +# +# ====> if you're using these dist rules, get hold of GNU findutils. +# +# --SOF 2/97 +# +.PHONY: dist dist-pre dist-post + +dist-pre:: + -rm -rf $(SRC_DIST_DIR) + -rm -f $(SRC_DIST_NAME).tar.gz + (cd $(FPTOOLS_TOP_ABS); find $(SRC_DIST_DIRS) -type d \( -name CVS -prune -o -name SRC -prune -o -exec $(MKDIRHIER) $(SRC_DIST_DIR)/{} \; \) ; ) + (cd $(FPTOOLS_TOP_ABS); find $(SRC_DIST_DIRS) -name CVS -prune -o -name SRC -prune -o -name "*~" -prune -o -name ".cvsignore" -prune -o -type l -exec $(LN_S) $(FPTOOLS_TOP_ABS)/{} $(SRC_DIST_DIR)/{} \; ) + +# +# After having created a shadow distribution tree and copied/linked +# all the necessary files to it, `dist-post' makes sure the permissions +# are set right and packages up the tree. +# +# For now, we make the packaging a separate rule, so as to allow +# the inspection of the dist tree before eventually packaging it up. +# +dist-post:: + ( cd $(SRC_DIST_DIR) ; cd .. ; chmod -R a+rw $(SRC_DIST_NAME) ) + +dist-package:: + cd $(SRC_DIST_DIR); cd ..; $(TAR) chzf $(SRC_DIST_NAME).tar.gz $(SRC_DIST_NAME) + +# +# The default dist rule: +# +# copy/link the contents of $(SRC_DIST_FILES) into the +# shadow distribution tree. SRC_DIST_FILES contain the +# build-generated files that you want to include in +# a source distribution. +# +# +ifneq "$(SRC_DIST_FILES)" "" +dist:: + @for i in $(SRC_DIST_FILES); do \ + if (test -f "$$i"); then \ + echo $(LN_S) `pwd`/$$i $(SRC_DIST_DIR)/$$i ; \ + $(LN_S) `pwd`/$$i $(SRC_DIST_DIR)/$$i ; \ + fi; \ + done; +endif + +# +# binary-dist creates a binary bundle, set BIN_DIST_NAME +# to package name and do `make binary-dist' (normally this +# just a thing you would do from the toplevel of fptools or) +# from the top of a project. +# +.PHONY: binary-dist-pre binary-dist binary-pack + +binary-dist-pre:: + -rm -rf $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) + -rm -f $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME).tar.gz + @for i in $(BIN_DIST_DIRS); do \ + if (test -d "$$i"); then \ + echo $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/bin/$(TARGETPLATFORM) \ + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/bin/$(TARGETPLATFORM) \ + echo $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/lib/$(TARGETPLATFORM)/$$i-$(ProjectVersion) \ + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/lib/$(TARGETPLATFORM)/$$i-$(ProjectVersion) \ + echo $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/share/$$i-$(ProjectVersion) \ + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/share/$$i-$(ProjectVersion) \ + echo $(MAKE) -C $$i $(MFLAGS) install BIN_DIST=1 BIN_DIST_NAME=$(BIN_DIST_NAME) prefix=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) exec_prefix=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) bindir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/bin/$(TARGETPLATFORM) libdir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/lib/$(TARGETPLATFORM)/$$i-$(ProjectVersion) libexecdir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/lib/$(TARGETPLATFORM)/$$i-$(ProjectVersion) datadir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/share/$$i-$(ProjectVersion); \ + $(MAKE) -C $$i $(MFLAGS) install BIN_DIST=1 BIN_DIST_NAME=$(BIN_DIST_NAME) prefix=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) exec_prefix=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) bindir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/bin/$(TARGETPLATFORM) libdir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/lib/$(TARGETPLATFORM)/$$i-$(ProjectVersion) libexecdir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/lib/$(TARGETPLATFORM)/$$i-$(ProjectVersion) datadir=$(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/share/$$i-$(ProjectVersion); \ + fi; \ + done + +# +# Do this separately for now +# +binary-pack:: + ( cd $(BIN_DIST_TMPDIR); $(TAR) chzf $(BIN_DIST_NAME).tar.gz $(BIN_DIST_NAME); rm -rf $(BIN_DIST_NAME) ) + +########################################### +# +# Targets: check tags show info +# +########################################### + +#------------------------------------------------------------ +# Check + +.PHONY: check + +check:: $(TESTS) + @for i in $(filter-out %.lhs .hs, $(TESTS)) ''; do \ + if (test -f "$$i"); then \ + echo Running: `basename $$i` ; \ + cd test; `basename $$i` ; \ + fi; \ + done; + +#------------------------------------------------------------ +# Tags + +.PHONY: TAGS + +TAGS:: $(SOURCES) + @$(RM) TAGS + @touch TAGS +ifneq "$(HS_SRCS)" "" + $(HSTAGS) $(HSTAGS_OPTS) -- $(HS_SRCS) +endif +ifneq "$(C_SRCS)" "" + etags -a $(C_SRCS) +endif + +#------------------------------------------------------------ +# Makefile debugging +# to see the effective value used for a Makefile variable, do +# make show VALUE=MY_VALUE +# + +show: + @echo '$(VALUE)=$($(VALUE))' + +#------------------------------------------------------------ +# Documentation + +.PHONY: dvi ps html info txt + +info:: $(filter %.texinfo, $(DOC_SRCS)) $(filter %.texi,$(DOC_SRCS)) +dvi:: $(DOC_DVI) +ps:: $(DOC_PS) +html:: $(DOC_HTML) +texi:: $(DOC_TEXI) +txt:: $(DOC_TEXT) + +# +# Building literate root documents requires extra treatment, +# as the root files need to be processed different from other +# literate files (`compile' them into .itex with the -S (standalone) +# option) and then link together a master TeX document with +# a -S option. +# +$(filter %.tex,$(patsubst %.lit,%.tex,$(DOC_SRCS))) : + @$(RM) $@ + $(LIT2LATEX) -S -c $(LIT2LATEX_OPTS) -o $(patsubst %.tex,%.itex,$@) $(addsuffix .lit,$(basename $@)) + $(LIT2LATEX) -S $(LIT2LATEX_OPTS) -o $@ $(addsuffix .itex,$(basename $@)) + @chmod 444 $@ +# +# Ditto for texi and html +# +$(filter %.texi,$(patsubst %.lit,%.texi,$(DOC_SRCS))) : + @$(RM) $@ + $(LIT2TEXI) -S -c $(LIT2TEXI_OPTS) -o $(patsubst %.texi,%.itxi,$@) $(addsuffix .lit,$(basename $@)) + $(LIT2TEXI) -S $(LIT2TEXI_OPTS) -o $@ $(addsuffix .itxi,$(basename $@)) + @chmod 444 $@ +# +# Rather than using lit2html, we opt for the lit-texi-html route, +# and use texi2html as our HTML backend. +# (Note: we need to change mkdependlit to get this really off the ground) +# +# If the generated html representation is split up into a myriad of files, +# put the files in a subdirectory html/, if a monolith is created, park +# the generated file in the same dir as the .lit file. +# +$(filter %.html,$(patsubst %.lit,%.html,$(DOC_SRCS))) : $(filter %.lit,$(DOC_SRCS)) + $(RM) $@ $(patsubst %.html,%.texi,$@) $(patsubst %.html,%.itxi,$@) +ifneq "$(filter -monolithic,$(TEXI2HTML_OPTS))" "" + $(LIT2TEXI) -S -c $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.itxi,$@) $(addsuffix .lit,$(basename $@)) + $(LIT2TEXI) -S $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.texi,$@) $(addsuffix .itxi,$(basename $@)) + $(TEXI2HTML) $(TEXI2HTML_OPTS) $(patsubst %.html,%.texi,$@) +else + $(RM) html/$(basename $@)* + $(MKDIRHIER) html + $(LIT2TEXI) -S -c $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.itxi,$@) $(addsuffix .lit,$(basename $@)) + $(LIT2TEXI) -S $(LIT2TEXI_OPTS) -o html/$(patsubst %.html,%.texi,$@) $(addsuffix .itxi,$(basename $@)) + (cd html; ../$(TEXI2HTML) $(TEXI2HTML_OPTS) $(patsubst %.html,%.texi,$@); cd ..) + @touch $@ +endif + +########################################### +# +# Targets: clean +# +########################################### + +.PHONY: realclean mostlyclean clean distclean maintainer-clean + +# realclean is just a synonym for maintainer-clean +realclean: maintainer-clean + + +ifneq "$(MOSTLY_CLEAN_FILES)" "" +mostlyclean:: + rm -f $(MOSTLY_CLEAN_FILES) +endif + +ifneq "$(CLEAN_FILES)" "" +clean:: mostlyclean + rm -f $(CLEAN_FILES) +endif + + +ifneq "$(DIST_CLEAN_FILES)" "" +distclean:: mostlyclean clean + rm -f $(DIST_CLEAN_FILES) +endif + + +ifneq "$(MAINTAINER_CLEAN_FILES)" "" +maintainer-clean:: mostlyclean clean distclean + @echo 'This command is intended for maintainers to use; it' + @echo 'deletes files that may need special tools to rebuild.' + rm -f $(MAINTAINER_CLEAN_FILES) +endif + +# +# If (Haskell) object files are split, cleaning up +# consist of descending into the directories where +# the myriads of object files have been put. +# + +ifneq "$(HS_OBJS)" "" +ifneq "$(filter -split-objs,$(HC_OPTS))" "" +clean :: + find $(patsubst %.$(way_)o,%,$(HS_OBJS)) -name '*.$(way_)o' -print | xargs $(RM) __rm_food; +endif +endif + + +################################################################################# +# +# Way management +# +################################################################################# + +# Here is the ingenious jiggery pokery that allows you to build multiple versions +# of a program in a single build tree. +# +# The ways setup requires the following variables to be set: +# +# Expects: $(WAYS) the possible "way" strings to one of +# which $(way) will be set + + +# So how does $(way) ever get set to anything? Answer, we recursively +# invoke make, setting $(way) on the command line. +# When do we do this recursion? Answer: whenever the programmer +# asks make to make a target that involves a way suffix. +# We must remember *not* to recurse again; but that's easy: we +# just see if $(way) is set: + +ifeq "$(way)" "" + +# If $(WAYS) = p mc, then WAY_TARGETS expands to +# %.p_lhs %.p_hs %.p_o ... %.mc_lhs %.p_hs ... +# and OTHER_WAY_TARGETS to +# %_p.a %_p %_mc.a %_mc +# where the suffixes are from $(SUFFIXES) +# +# We have to treat libraries and "other" targets differently, +# because their names are of the form +# libHS_p.a and Foo_p +# whereas everything else has names of the form +# Foo.p_o + +FPTOOLS_SUFFIXES := o hi hc + +WAY_TARGETS = $(foreach way,$(WAYS),$(foreach suffix, $(FPTOOLS_SUFFIXES), %.$(way)_$(suffix))) +LIB_WAY_TARGETS = $(foreach way,$(WAYS),%_$(way).a %_$(way)) + +# $@ will be something like Foo.p_o +# $(suffix $@) will be .p_o +# The sed script extracts the "p" part. + +$(WAY_TARGETS) : + $(MAKE) way=$(basename $(subst _,.,$(subst .,,$(suffix $@)))) $@ + +# $(@F) will be something like libHS_p.a, or Foo_p +# $(basename $(@F)) will be libHS_p, or Foo_p +# The sed script extracts the "p" part. + +$(LIB_WAY_TARGETS) : + $(MAKE) $(MFLAGS) $@ way=$(subst .,,$(suffix $(subst _,.,$(basename $@)))) + +endif # if way + + +################################################################## +# +# Recursive stuff +# +################################################################## + +# Here are the diabolically clever rules that +# +# (a) for each "recursive target" <t> +# propagates "make <t>" to directories in SUBDIRS +# +# (b) when SUBDIRS is empty, +# for each "multi-way-target" <t> +# calls "make -way=w <t>" for each w in $(WAYS) +# +# This has the effect of making the standard target +# in each of the specified ways (as well as in the normal way + +# Controlling variables +# WAYS = extra (beyond the normal way) ways to build things in +# SUBDIRS = subdirectories to recurse into + +# No ways, so iterate over the SUBDIRS + +ifeq "$(way)" "" +ifneq "$(SUBDIRS)" "" + +all docs runtests boot TAGS clean veryclean maintainer-clean install info :: + @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ + for i in $(SUBDIRS) ; do \ + $(MAKE) -C $$i $(MFLAGS) $@; \ + done + +dist :: + @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ + for i in $(SUBDIRS) ; do \ + $(MKDIRHIER_PREFIX)mkdirhier $(SRC_DIST_DIR)/$$i; \ + $(MAKE) -C $$i $(MFLAGS) $@ SRC_DIST_DIR=$(SRC_DIST_DIR)/$$i; \ + done +endif +endif + +# +# Selectively building subdirectories. +# +# +ifneq "$(SUBDIRS)" "" +$(SUBDIRS) :: + $(MAKE) -C $@ $(MFLAGS) +endif + +ifneq "$(WAYS)" "" +ifeq "$(way)" "" + +# NB: the targets exclude +# boot info TAGS +# since these are way-independent +all docs runtests TAGS clean veryclean maintainer-clean install :: + for i in $(WAYS) ; do \ + $(MAKE) way=$$i $(MFLAGS) $@ ; \ + done + +endif +endif + diff --git a/mk/utils.mk.in b/mk/utils.mk.in deleted file mode 100644 index 402c0e162b..0000000000 --- a/mk/utils.mk.in +++ /dev/null @@ -1,382 +0,0 @@ -#----------------------------------------------------------------------------- -# $Id: utils.mk.in,v 1.3 1996/11/22 13:24:01 simonm Exp $ - -# This file is automatically generated by configure, and should not be -# changed. -# -# Most of this stuff is designed to be overridable: just set the appropriate -# variable in the Makefile after including ghc.mk. - -# This file replaces site.jm, site-DEF.jm, utils-GEN.jm in the jmake system. - -#----------------------------------------------------------------------------- -# Random configuration stuff - -TOP_PWD = @hardtop@ -TMPDIR = @TmpDir@ - -HcMaxHeapFlag = @HcMaxHeapFlag@ -HcMaxStackFlag = @HcMaxStackFlag@ -ALL_PROJECTS_HC_OPTS += $(HcMaxHeapFlag) $(HcMaxStackFlag) - -#----------------------------------------------------------------------------- -# C compiler stuff - -HaveGcc = @HaveGcc@ -UseGcc = @HaveGcc@ -WhatGccIsCalled = @WhatGccIsCalled@ -CC = cc -ifeq ($(HaveGcc), YES) -ifeq ($(UseGcc), YES) -CC = $(WhatGccIsCalled) -endif -endif - -LD = ld -LINT = lint -AS = as -STRIP = strip -YACC = @YaccCmd@ - -CPP = @RAWCPP@ $(GLUED_CPP_INCLUDES) $(GLUED_CPP_DEFINES) -PREPROCESSCMD = $(CC) -E $(GLUED_CPP_INCLUDES) $(GLUED_CPP_DEFINES) -RAWCPP = @RAWCPP@ - -AR = @ArCmd@ -RANLIB = @RANLIB@ - -#----------------------------------------------------------------------------- -# lex - -EightBitLexCmd = @LEX@ -s -8 -FLEX = $(EightBitLexCmd) $(EXTRA_FLEX_OPTS) -FLEX_LIB = @LEXLIB@ - -#----------------------------------------------------------------------------- -# general utilities - -PERL = @PerlCmd@ -SHELL = /bin/sh -COMPRESS = compress -CONTEXT_DIFF = @ContextDiffCmd@ -CP = cp -LN = ln -s -MV = mv -RM = rm -f -TIME = time -CTAGS = $(ETAGS) -INSTALL = @INSTALL@ -MAKE = @MakeCmd@ -UNAME = uname - -#----------------------------------------------------------------------------- -# Haskell compiler - -HC = @WithHc@ -HaskellCompilerType = @WithHcType@ - -#----------------------------------------------------------------------------- -# Document preparation - -TROFF = troff -NROFF = nroff -MANMACROS = -man -MSMACROS = -ms -PIC = pic -TBL = tbl -TGRIND = tgrind -TGRIND_HELPER = /usr/local/lib/tgrind/tfontedpr # XXX - -PRINTER = lpr - -TEX = tex -LATEX = latex - -TIB = tib - -#----------------------------------------------------------------------------- -# sources - -ifndef UseInstalledUtils -UTILSRC = $(TOP)/glafp-utils -SCRIPTSRC = $(UTILSRC)/scripts -endif - -#----------------------------------------------------------------------------- -# Cleaning things. - -FilesToClean = \ - *.CKP *.ln *.BAK *.bak *.o core a.out errs ,* *.a .emacs_* \ - tags TAGS *.ind *.ilg *.idx *.idx-prev *.aux *.aux-prev *.dvi *.log \ - *.toc *.lot *.lof *.blg *.info *.itxi *.itex *.cb - -ExtraFilesToBeVeryClean = \ - .??*~ *~ *.orig *.rej .depend - -#----------------------------------------------------------------------------- -# Info stuff - -ifdef UseInstalledUtils -INFO = info -MAKEINFO = makeinfo -POSTMAKEINFO = postmakeinfo -else -INFOSRC = $(LITSRC)/info-utils -INFO = $(UTILSRC)/info -MAKEINFO = $(INFOSRC)/makeinfo -POSTMAKEINFO = $(INFOSRC)/postmakeinfo -endif - -#----------------------------------------------------------------------------- -# literate programming stuff - -LIT2PGM = lit2pgm -LIT2TEXI = lit2texi -LIT2HTML = lit2html -LIT2LATEX = lit2latex -MKDEPENDLIT = mkdependlit -LIT2CHANGELOG = lit2changelog - -ifndef UseInstalledUtils -LITSRC = $(TOP)/literate -endif - -#----------------------------------------------------------------------------- -# Various scripts - -ifdef UseInstalledUtils -MKDEPENDC = mkdependC -f .depend -else -MKDEPENDC = $(MKDEPENDCSRC)/mkdependC -f .depend -MKDEPENDCSRC = $(UTILSRC)/mkdependC -endif - -ifdef UseInstalledUtils -FASTMAKE = fastmake -else -FASTMAKE = $(FASTMAKESRC)/fastmake -FASTMAKESRC = $(UTILSRC)/fastmake -endif - -ifdef UseInstalledUtils -LTX = ltx -else -LTX = $(LTXSRC)/ltx -LTXSRC = $(UTILSRC)/ltx -endif - -ifdef UseInstalledUtils -MKDIRHIER = mkdirhier -else -MKDIRHIER = $(MKDIRHIERSRC)/mkdirhier -MKDIRHIERSRC = $(UTILSRC)/mkdirhier -endif - -ifdef UseInstalledUtils -LNDIR = lndir -else -LNDIR = $(LNDIRSRC)/lndir -LNDIRSRC = $(UTILSRC)/lndir -endif - -ifdef UseInstalledUtils -MSUB = msub -else -MSUB = $(MSUBSRC)/msub -MSUBSRC = $(UTILSRC)/msub -endif - -ifdef UseInstalledUtils -ETAGS = etags -else -ETAGS = $(ETAGSSRC)/etags -ETAGSSRC = $(UTILSRC)/etags -endif - -ifdef UseInstalledUtils -VERBATIM = verbatim -else -VERBATIM = $(VERBATIMSRC)/verbatim -VERBATIMSRC = $(UTILSRC)/verbatim -endif - -ifdef UseInstalledUtils -RUNSTDTEST = runstdtest -else -RUNSTDTEST = $(RUNSTDTESTSRC)/runstdtest -RUNSTDTESTSRC = $(UTILSRC)/runstdtest -endif - -#----------------------------------------------------------------------------- -# glued flags lists - -GLUED_CPP_INCLUDES = \ - $(ALL_PROJECTS_CPP_INCLUDES) \ - $(PLATFORM_CPP_INCLUDES) \ - $(PROJECT_CPP_INCLUDES) \ - $(CPP_INCLUDES) \ - $(EXTRA_CPP_INCLUDES) - -GLUED_CPP_DEFINES = \ - $(ALL_PROJECTS_CPP_DEFINES) \ - $(PLATFORM_CPP_DEFINES) \ - $(PROJECT_CPP_DEFINES) \ - $(CPP_DEFINES) \ - $(EXTRA_CPP_DEFINES) - -GLUED_CC_OPTS = \ - $(ALL_PROJECTS_CC_OPTS) \ - $(PLATFORM_CC_OPTS) \ - $(PROJECT_CC_OPTS) \ - $(CC_OPTS) \ - $(EXTRA_CC_OPTS) - -CFLAGS = $(GLUED_CPP_INCLUDES) $(GLUED_CPP_DEFINES) $(GLUED_CC_OPTS) - -GLUED_YACC_OPTS = \ - $(ALL_PROJECTS_YACC_OPTS) \ - $(PLATFORM_YACC_OPTS) \ - $(PROJECT_YACC_OPTS) \ - $(YACC_OPTS) \ - $(EXTRA_YACC_OPTS) - -YFLAGS = $(GLUED_YACC_OPTS) - -GLUED_HC_OPTS = \ - $(ALL_PROJECTS_HC_OPTS) \ - $(PLATFORM_HC_OPTS) \ - $(PROJECT_HC_OPTS) \ - $(HC_OPTS) \ - $(EXTRA_HC_OPTS) - -GLUED_HC_IMPORTS = \ - $(ALL_PROJECTS_HC_IMPORTS) \ - $(PLATFORM_HC_IMPORTS) \ - $(PROJECT_HC_IMPORTS) \ - $(HC_IMPORTS) \ - $(EXTRA_HC_IMPORTS) - -HCFLAGS = $(GLUED_HC_IMPORTS) $(GLUED_CPP_DEFINES) $(GLUED_HC_OPTS) - -GLUED_LD_OPTS = \ - $(ALL_PROJECTS_LD_OPTS) \ - $(PLATFORM_LD_OPTS) \ - $(PROJECT_LD_OPTS) \ - $(LD_OPTS) \ - $(EXTRA_LD_OPTS) - -GLUED_LD_LIBRARIES = \ - $(ALL_PROJECTS_LD_LIBRARIES) \ - $(PLATFORM_LD_LIBRARIES) \ - $(PROJECT_LD_LIBRARIES) \ - $(LD_LIBRARIES) \ - $(EXTRA_LD_LIBRARIES) - -LDOPTIONS = $(GLUED_LD_OPTS) $(GLUED_LD_LIBRARIES) - -# ToDo: lint stuff not tidied up yet - -LINTLIBFLAG = -C -LINTOPTS = -axz -LINTFLAGS = $(LINTOPTS) -DLINT $(GLUED_CPP_INCLUDES) $(GLUED_CPP_DEFINES) - -GLUED_GENLIT_OPTS = \ - $(ALL_PROJECTS_GENLIT_OPTS) \ - $(PLATFORM_GENLIT_OPTS) \ - $(PROJECT_GENLIT_OPTS) \ - $(GENLIT_OPTS) \ - $(EXTRA_GENLIT_OPTS) - -GLUED_LIT2PGM_OPTS = \ - $(ALL_PROJECTS_LIT2PGM_OPTS) \ - $(PLATFORM_LIT2PGM_OPTS) \ - $(PROJECT_LIT2PGM_OPTS) \ - $(LIT2PGM_OPTS) \ - $(EXTRA_LIT2PGM_OPTS) - -GLUED_LIT2TEXI_OPTS = \ - $(ALL_PROJECTS_LIT2TEXI_OPTS) \ - $(PLATFORM_LIT2TEXI_OPTS) \ - $(PROJECT_LIT2TEXI_OPTS) \ - $(LIT2TEXI_OPTS) \ - $(EXTRA_LIT2TEXI_OPTS) - -GLUED_LIT2HTML_OPTS = \ - $(ALL_PROJECTS_LIT2HTML_OPTS) \ - $(PLATFORM_LIT2HTML_OPTS) \ - $(PROJECT_LIT2HTML_OPTS) \ - $(LIT2HTML_OPTS) \ - $(EXTRA_LIT2HTML_OPTS) - -GLUED_LIT2LATEX_OPTS = \ - $(ALL_PROJECTS_LIT2LATEX_OPTS) \ - $(PLATFORM_LIT2LATEX_OPTS) \ - $(PROJECT_LIT2LATEX_OPTS) \ - $(LIT2LATEX_OPTS) \ - $(EXTRA_LIT2LATEX_OPTS) - -GLUED_LIT2CHANGELOG_OPTS = \ - $(ALL_PROJECTS_LIT2CHANGELOG_OPTS) \ - $(PLATFORM_LIT2CHANGELOG_OPTS) \ - $(PROJECT_LIT2CHANGELOG_OPTS) \ - $(LIT2CHANGELOG_OPTS) \ - $(EXTRA_LIT2CHANGELOG_OPTS) - -GLUED_MKDEPENDLIT_OPTS = \ - $(ALL_PROJECTS_MKDEPENDLIT_OPTS) \ - $(PLATFORM_MKDEPENDLIT_OPTS) \ - $(PROJECT_MKDEPENDLIT_OPTS) \ - $(MKDEPENDLIT_OPTS) \ - $(EXTRA_MKDEPENDLIT_OPTS) - -LIT2PGMFLAGS = $(GLUED_GENLIT_OPTS) $(GLUED_LIT2PGM_OPTS) -LIT2TEXIFLAGS = $(GLUED_GENLIT_OPTS) $(GLUED_LIT2TEXI_OPTS) -LIT2HTMLFLAGS = $(GLUED_GENLIT_OPTS) $(GLUED_LIT2HTML_OPTS) -LIT2LATEXFLAGS = $(GLUED_GENLIT_OPTS) $(GLUED_LIT2LATEX_OPTS) -LIT2CHANGELOGFLAGS = $(GLUED_GENLIT_OPTS) $(GLUED_LIT2CHANGELOG_OPTS) -MKDEPENDLITFLAGS = $(GLUED_GENLIT_OPTS) $(GLUED_MKDEPENDLIT_OPTS) - -GLUED_MKDEPENDC_OPTS = \ - $(ALL_PROJECTS_MKDEPENDC_OPTS) \ - $(PLATFORM_MKDEPENDC_OPTS) \ - $(PROJECT_MKDEPENDC_OPTS) \ - $(MKDEPENDC_OPTS) \ - $(EXTRA_MKDEPENDC_OPTS) - -MKDEPENDCFLAGS = $(GLUED_MKDEPENDC_OPTS) - -GLUED_MKDEPENDHS_OPTS = \ - $(ALL_PROJECTS_MKDEPENDHS_OPTS) \ - $(PLATFORM_MKDEPENDHS_OPTS) \ - $(PROJECT_MKDEPENDHS_OPTS) \ - $(MKDEPENDHS_OPTS) \ - $(EXTRA_MKDEPENDHS_OPTS) - -MKDEPENDHSFLAGS = $(GLUED_MKDEPENDHS_OPTS) - -GLUED_CTAGS_OPTS = \ - $(ALL_PROJECTS_CTAGS_OPTS) \ - $(PLATFORM_CTAGS_OPTS) \ - $(PROJECT_CTAGS_OPTS) \ - $(CTAGS_OPTS) \ - $(EXTRA_CTAGS_OPTS) - -CTAGSFLAGS = $(GLUED_CTAGS_OPTS) - -GLUED_RUNSTDTEST_OPTS = \ - $(ALL_PROJECTS_RUNSTDTEST_OPTS) \ - $(PLATFORM_RUNSTDTEST_OPTS) \ - $(PROJECT_RUNSTDTEST_OPTS) \ - $(RUNSTDTEST_OPTS) \ - $(EXTRA_RUNSTDTEST_OPTS) - -RUNSTDTEST_FLAGS = $(GLUED_RUNSTDTEST_OPTS) - -GLUED_MSUB_OPTS = \ - $(ALL_PROJECTS_MSUB_OPTS) \ - $(PLATFORM_MSUB_OPTS) \ - $(PROJECT_MSUB_OPTS) \ - $(MSUB_OPTS) \ - $(EXTRA_MSUB_OPTS) - -MSUBFLAGS = $(GLUED_MSUB_OPTS) |
