diff options
| author | partain <unknown> | 1996-06-27 16:00:09 +0000 |
|---|---|---|
| committer | partain <unknown> | 1996-06-27 16:00:09 +0000 |
| commit | a7e6cdbfc4f27c2e0ab9c12ebe6431c246c74c6d (patch) | |
| tree | 07b816ec8e1aa3887a068287968240e4516d6f21 | |
| parent | 26741ec416bae2c502ef00a2ba0e79050a32cb67 (diff) | |
| download | haskell-a7e6cdbfc4f27c2e0ab9c12ebe6431c246c74c6d.tar.gz | |
[project @ 1996-06-27 15:55:53 by partain]
partain 1.3 changes to 960626
61 files changed, 4070 insertions, 5195 deletions
diff --git a/ANNOUNCE-2.01 b/ANNOUNCE-2.01 new file mode 100644 index 0000000000..0fc4ab0f1b --- /dev/null +++ b/ANNOUNCE-2.01 @@ -0,0 +1,165 @@ + The Glasgow Haskell Compiler -- version 2.01 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We are proud to announce the first public release of the Glasgow +Haskell Compiler (GHC) for the revised Haskell 1.3 language. Sources +and binaries are freely available by anonymous FTP and on the +World-Wide Web; details below. + +GHC 2.01 is a test-quality release, worth trying if you are a gung-ho +Haskell user or if you want to ensure that we quickly fix bugs that +affect your programs :-) We advise *AGAINST* deleting your copy of +that old workhorse GHC 0.26 (for Haskell 1.2), and *AGAINST* relying +on this compiler (2.01) in any way. With your help in testing 2.01, +we hope to release a more solid Haskell 1.3 compiler relatively soon. + +Haskell is "the" standard lazy functional programming language [see +SIGPLAN Notices, May 1992]. The current language version is 1.3, +agreed in May, 1996. + +The Glasgow Haskell project seeks to bring the power and elegance of +functional programming to bear on real-world problems. To that end, +GHC lets you call C (including cross-system garbage collection), +provides good profiling tools, supports ever richer I/O, and +concurrency and parallelism. Our goal is to make it the "tool of +choice for real-world applications". + +GHC 2.01 is quite different from 0.26 (July 1995), as the new version +number suggests. (The 1.xx numbers are reserved for any Haskell-1.2 +compiler releases.) Changes worth noting include: + +....... + + * Concurrent Haskell: with this, you can build programs out of many + I/O-performing, interacting `threads'. We have a draft paper + about Concurrent Haskell, and our forthcoming Haggis GUI toolkit + uses it. + + * Parallel Haskell, running on top of PVM (Parallel Virtual Machine) + and hence portable to pretty much any parallel architecture, + whether shared memory or distributed memory. With this, your + Haskell program runs on multiple processors, guided by `par` and + `seq` annotations. The first pretty-much-everyone-can-try-it + parallel functional programming system! NB: The parallel stuff is + "research-tool quality"... consider this an alpha release. + + * "Foldr/build" deforestation (by Andy Gill) is in, as are + "SPECIALIZE instance" pragmas (by Patrick Sansom). + + * The LibPosix library provides an even richer I/O interface than + the standard 1.3 I/O library. A program like a shell or an FTP + client can be written in Haskell -- examples included. + + * Yet more cool libraries: Readline (GNU command-line editing), + Socket (BSD sockets), Regex and MatchPS (GNU regular expressions). + By Darren Moffat and Sigbjorn Finne. + + * New ports -- Linux (a.out) and MIPS (Silicon Graphics). + + * NB: configuration has changed yet again -- for the better, of + course :-) + +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, GNU C +(`gcc'), and `perl'. We have seen GHC 0.26 work on these platforms: +alpha-dec-osf2, hppa1.1-hp-hpux9, i386-unknown-linuxaout, +m68k-sun-sunos4, mips-sgi-irix5, and sparc-sun-{sunos4,solaris2}. +Similar platforms should work with minimal hacking effort. +The installer's guide give a full what-ports-work report. + +Binaries are now 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 glasgow-haskell-{users,bugs}-request@dcs.glasgow.ac.uk. +Please send bug reports to glasgow-haskell-bugs. + +Particular thanks to: Jim Mattson (author of much of the code) who has +now moved to HP in California; and the Turing Institute who donated a +lot of SGI cycles for the SGI port. + +Simon Peyton Jones and Will Partain + +Dated: 95/07/24 + +Relevant URLs on the World-Wide Web: + +GHC home page http://www.dcs.glasgow.ac.uk/fp/software/ghc.html +Glasgow FP group page http://www.dcs.glasgow.ac.uk/fp/ +comp.lang.functional FAQ http://www.cs.nott.ac.uk/Department/Staff/mpj/faq.html + +====================================================================== +How to get GHC 0.26: + +This release is available by anonymous FTP from the main Haskell +archive sites, in the directory pub/haskell/glasgow: + + ftp.dcs.glasgow.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-0.26-src.tar.gz The source distribution; about 3MB. + +ghc-0.26.ANNOUNCE This file. + +ghc-0.26.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-0.26-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +ghc-0.26-<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-linuxaout + i386-unknown-solaris2 + m68k-sun-sunos4 + mips-sgi-irix5 + sparc-sun-sunos4 + sparc-sun-solaris2 + +ghc-0.26-<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-0.26-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-0.26-<bundle>-hc-files.tar.gz Further sets of .hc files, for + building other "bundles", e.g., profiling. + +ghc-0.26-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.) + +We could provide diffs from previous versions of GHC, should you +require them. A full set would be very large (7MB). diff --git a/Makefile.in b/Makefile.in index 3626858c95..93b4582e5a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -31,6 +31,6 @@ Makefile: Makefile.in config.status config.status: configure $(SHELL) config.status --recheck configure: configure.in - cd $(srcdir); autoconf < configure.in > configure.new + cd $(srcdir) && autoconf < configure.in > configure.new grep -v '# Generated automatically from' < configure.new > configure diff --git a/STARTUP.in b/STARTUP.in index 814426aa8f..0416b7fe50 100644 --- a/STARTUP.in +++ b/STARTUP.in @@ -30,15 +30,15 @@ esac for i in @DoingMkWorld@ @DoingGlaFpUtils@ @DoingLiterate@ ; do if [ -d $i ] ; then - ( set -e; \ - cd $i ; \ - echo '' ; \ - echo "*** configuring $i ..." ; \ - make -f Makefile.BOOT BOOT_DEFINES="-P none -S std -DTopDirPwd=$hardtop"; \ - echo '' ; \ - echo "*** making Makefiles in $i ..." ; \ - make Makefile ; \ - make Makefiles \ + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** configuring $i ..." ; \ + @MakeCmd@ -f Makefile.BOOT BOOT_DEFINES="-P none -S std -DTopDirPwd=$hardtop"; \ + echo '' ; \ + echo "*** making Makefiles in $i ..." ; \ + @MakeCmd@ Makefile ; \ + @MakeCmd@ Makefiles \ ) else echo warning: $i is not a directory -- doing nothing for it @@ -49,14 +49,14 @@ done for i in @DoingMkWorld@ @DoingGlaFpUtils@ @DoingLiterate@ ; do if [ -d $i ] ; then - ( set -e; \ - cd $i ; \ - echo '' ; \ - echo "*** making dependencies in $i ..." ; \ - make depend ; \ - echo '' ; \ - echo "*** making all in $i ..." ; \ - make all \ + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** making dependencies in $i ..." ; \ + @MakeCmd@ depend ; \ + echo '' ; \ + echo "*** making all in $i ..." ; \ + @MakeCmd@ all \ ) else echo warning: $i is not a directory -- doing nothing for it @@ -67,22 +67,22 @@ done passed_in_setup="-S @MkWorldSetup@" -for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do +for i in @DoingGHC@ @DoingHsLibs@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do if [ $i = nofib ] ; then setup=$passed_in_setup else setup='' fi if [ -d $i ] ; then - ( set -e; \ - cd $i ; \ - echo '' ; \ - echo "*** configuring $i ..." ; \ - make -f Makefile.BOOT BOOT_DEFINES="-P $i $setup -C mkworld -DTopDirPwd=$hardtop"; \ - echo '' ; \ - echo "*** making Makefiles in $i ..." ; \ - make Makefile ; \ - make Makefiles \ + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** configuring $i ..." ; \ + @MakeCmd@ -f Makefile.BOOT BOOT_DEFINES="-P $i $setup -C mkworld -DTopDirPwd=$hardtop"; \ + echo '' ; \ + echo "*** making Makefiles in $i ..." ; \ + @MakeCmd@ Makefile ; \ + @MakeCmd@ Makefiles \ ) else if [ $i != EndOfList ] ; then @@ -93,13 +93,13 @@ done # Finally, the dependencies -for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do +for i in @DoingGHC@ @DoingHsLibs@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do if [ -d $i ] ; then - ( set -e; \ - cd $i ; \ - echo '' ; \ - echo "*** making dependencies in $i ..." ; \ - make depend \ + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** making dependencies in $i ..." ; \ + @MakeCmd@ depend \ ) else if [ $i != EndOfList ] ; then @@ -112,7 +112,7 @@ echo '' echo '*******************************************************************' echo "* Looking good! All you should need to do now is... *" echo '* *' -for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do +for i in @DoingGHC@ @DoingHsLibs@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do if [ $i != EndOfList ] ; then echo " cd $i" if [ $i = nofib ] ; then diff --git a/config.guess b/config.guess index 41f828ab7b..c3c4e799a6 100644 --- a/config.guess +++ b/config.guess @@ -1,6 +1,6 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +# Copyright (C) 1992, 93, 94, 95, 1996 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -14,7 +14,7 @@ # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a @@ -51,14 +51,21 @@ trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15 # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - alpha:OSF1:V*:*) + alpha:OSF1:[VX]*:*) # After 1.2, OSF1 uses "V1.3" for uname -r. - echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'` + # After 4.x, OSF1 uses "X4.x" for uname -r. + echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VX]//'` exit 0 ;; alpha:OSF1:*:*) # 1.2 uses "1.2" for uname -r. echo alpha-dec-osf${UNAME_RELEASE} exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit 0 ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-cbm-sysv4 + exit 0;; amiga:NetBSD:*:*) echo m68k-cbm-netbsd${UNAME_RELEASE} exit 0 ;; @@ -111,9 +118,15 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit 0 ;; + mips:*:4*:UMIPS) + echo mips-mips-riscos4sysv + exit 0 ;; mips:*:5*:RISCos) echo mips-mips-riscos${UNAME_RELEASE} exit 0 ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit 0 ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit 0 ;; @@ -124,12 +137,17 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in echo m88k-motorola-sysv3 exit 0 ;; AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`uname -p` + if [ $UNAME_PROCESSOR = mc88100 -o $UNAME_PROCESSOR = mc88100 ] ; then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \ -o ${TARGET_BINARY_INTERFACE}x = x ] ; then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi + else echo i586-dg-dgux${UNAME_RELEASE} + fi exit 0 ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 @@ -181,10 +199,8 @@ EOF else IBM_ARCH=powerpc fi - if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then - IBM_REV=4.1 - elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then - IBM_REV=4.1.1 + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` else IBM_REV=4.${UNAME_RELEASE} fi @@ -215,7 +231,7 @@ EOF case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;; + 9000/7?? | 9000/8?[679] ) HP_ARCH=hppa1.1 ;; 9000/8?? ) HP_ARCH=hppa1.0 ;; esac HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` @@ -251,13 +267,13 @@ EOF rm -f dummy.c dummy echo unknown-hitachi-hiuxwe2 exit 0 ;; - 9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* ) + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit 0 ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit 0 ;; - hp7??:OSF1:*:* | hp8?7:OSF1:*:* ) + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit 0 ;; hp8??:OSF1:*:*) @@ -308,19 +324,38 @@ EOF *:NetBSD:*:*) echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` exit 0 ;; + i*:CYGWIN*:*) + echo i386-unknown-cygwin32 + exit 0 ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin32 + exit 0 ;; *:GNU:*:*) echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit 0 ;; *:Linux:*:*) - # Systems without a BFD linker - if test -d /usr/lib/ldscripts/. ; then - : + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. + ld_help_string=`ld --help 2>&1` + if echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: elf_i[345]86"; then + echo "${UNAME_MACHINE}-unknown-linux" ; exit 0 + elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: i[345]86linux"; then + echo "${UNAME_MACHINE}-unknown-linuxaout" ; exit 0 + elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: i[345]86coff"; then + echo "${UNAME_MACHINE}-unknown-linuxcoff" ; exit 0 + elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: m68kelf"; then + echo "${UNAME_MACHINE}-unknown-linux" ; exit 0 + elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: m68klinux"; then + echo "${UNAME_MACHINE}-unknown-linuxaout" ; exit 0 + elif test "${UNAME_MACHINE}" = "alpha" ; then + echo alpha-unknown-linux ; exit 0 else - echo "${UNAME_MACHINE}-unknown-linuxoldld" - exit 0 - fi - # Determine whether the default compiler is a.out or elf - cat >dummy.c <<EOF + # Either a pre-BFD a.out linker (linuxoldld) or one that does not give us + # useful --help. Gcc wants to distinguish between linuxoldld and linuxaout. + test ! -d /usr/lib/ldscripts/. \ + && echo "${UNAME_MACHINE}-unknown-linuxoldld" && exit 0 + # Determine whether the default compiler is a.out or elf + cat >dummy.c <<EOF main(argc, argv) int argc; char *argv[]; @@ -333,8 +368,9 @@ char *argv[]; return 0; } EOF - ${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0 - rm -f dummy.c dummy;; + ${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + fi ;; # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions # are messed up and put the nodename in both sysname and nodename. i[34]86:DYNIX/ptx:4*:*) @@ -354,6 +390,8 @@ EOF elif /bin/uname -X 2>/dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL else echo ${UNAME_MACHINE}-unknown-sysv32 @@ -384,19 +422,19 @@ EOF 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) uname -p 2>/dev/null | grep 86 >/dev/null \ && echo i486-ncr-sysv4 && exit 0 ;; - m680[234]0:LynxOS:2.2*:*) + m680[234]0:LynxOS:2.[23]*:*) echo m68k-lynx-lynxos${UNAME_RELEASE} exit 0 ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit 0 ;; - i[34]86:LynxOS:2.2*:*) + i[34]86:LynxOS:2.[23]*:*) echo i386-lynx-lynxos${UNAME_RELEASE} exit 0 ;; - TSUNAMI:LynxOS:2.2*:*) + TSUNAMI:LynxOS:2.[23]*:*) echo sparc-lynx-lynxos${UNAME_RELEASE} exit 0 ;; - rs6000:LynxOS:2.2*:*) + rs6000:LynxOS:2.[23]*:*) echo rs6000-lynx-lynxos${UNAME_RELEASE} exit 0 ;; RM*:SINIX-*:*:*) @@ -410,12 +448,26 @@ EOF echo ns32k-sni-sysv fi exit 0 ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit 0 ;; + R3000:*System_V*:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit 0 ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 cat >dummy.c <<EOF +#ifdef _SEQUENT_ +# include <sys/types.h> +# include <sys/utsname.h> +#endif main () { #if defined (sony) @@ -479,7 +531,18 @@ main () #endif #if defined (_SEQUENT_) - printf ("i386-sequent-ptx\n"); exit (0); + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + #endif #if defined (vax) diff --git a/config.sub b/config.sub index 93371be14b..c462f8a1ca 100644 --- a/config.sub +++ b/config.sub @@ -1,6 +1,6 @@ #! /bin/sh # Configuration validation subroutine script, version 1.1. -# Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +# Copyright (C) 1991, 92, 93, 94, 95, 1996 Free Software Foundation, Inc. # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. @@ -17,7 +17,8 @@ # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +# Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a @@ -84,9 +85,27 @@ case $os in os= basic_machine=$1 ;; + -sim | -cisco | -oki | -wec | -winbond ) # CYGNUS LOCAL + os= + basic_machine=$1 + ;; + -apple*) # CYGNUS LOCAL + os= + basic_machine=$1 + ;; + -scout) # CYGNUS LOCAL + ;; + -wrs) # CYGNUS LOCAL + os=vxworks + basic_machine=$1 + ;; -hiux*) os=-hiuxwe2 ;; + -sco5) + os=sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` @@ -122,19 +141,31 @@ case $os in -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; + -psos*) + os=-psos + ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. - tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ + tahoe | i[3456]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ | arme[lb] | pyramid \ | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ - | alpha | we32k | ns16k | clipper | sparclite | i370 | sh \ - | powerpc | powerpcle | sparc64 | 1750a | dsp16xx | mips64 | mipsel \ + | alpha | we32k | ns16k | clipper | i370 | sh \ + | powerpc | powerpcle | 1750a | dsp16xx | mips64 | mipsel \ | pdp11 | mips64el | mips64orion | mips64orionel \ - | sparc) + | sparc | sparclet | sparclite | sparc64) + basic_machine=$basic_machine-unknown + ;; + m88110 | m680[01234]0 | m683?2 | m68360 | z8k | v70 | h8500 | w65) # CYGNUS LOCAL + basic_machine=$basic_machine-unknown + ;; + mips64vr4300 | mips64vr4300el) # CYGNUS LOCAL jsmith/vr4300 + basic_machine=$basic_machine-unknown + ;; + mips64vr4100 | mips64vr4100el) # CYGNUS LOCAL jsmith/vr4100 basic_machine=$basic_machine-unknown ;; # Object if more than one company name word. @@ -143,8 +174,8 @@ case $basic_machine in exit 1 ;; # Recognize the basic CPU types with company name. - vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \ - | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ + vax-* | tahoe-* | i[3456]86-* | i860-* | m68k-* | m68000-* | m88k-* \ + | sparc-* | ns32k-* | fx80-* | arm-* | arme[lb]-* | c[123]* \ | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \ | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \ | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \ @@ -152,14 +183,32 @@ case $basic_machine in | pdp11-* | sh-* | powerpc-* | powerpcle-* | sparc64-* | mips64-* | mipsel-* \ | mips64el-* | mips64orion-* | mips64orionel-*) ;; + m88110-* | m680[01234]0-* | m683?2-* | m68360-* | z8k-* | h8500-*) # CYGNUS LOCAL + ;; + mips64vr4300-* | mips64vr4300el-*) # CYGNUS LOCAL jsmith/vr4300 + ;; + mips64vr4100-* | mips64vr4100el-*) # CYGNUS LOCAL jsmith/vr4100 + ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. + 386bsd) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-bsd + ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; + a29khif) # CYGNUS LOCAL + basic_machine=a29k-amd + os=-udi + ;; + adobe68k) # CYGNUS LOCAL + basic_machine=m68010-adobe + os=-scout + ;; alliant | fx80) basic_machine=fx80-alliant ;; @@ -189,6 +238,18 @@ case $basic_machine in basic_machine=m68k-apollo os=-sysv ;; + apollo68bsd) # CYGNUS LOCAL + basic_machine=m68k-apollo + os=-bsd + ;; + arm | armel | armeb) + basic_machine=arm-arm + os=-aout + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; balance) basic_machine=ns32k-sequent os=-dynix @@ -257,6 +318,10 @@ case $basic_machine in encore | umax | mmax) basic_machine=ns32k-encore ;; + es1800 | OSE68k | ose68k | ose | OSE) # CYGNUS LOCAL + basic_machine=m68k-ericsson + os=-ose + ;; fx2800) basic_machine=i860-alliant ;; @@ -275,6 +340,14 @@ case $basic_machine in basic_machine=h8300-hitachi os=-hms ;; + h8300xray) # CYGNUS LOCAL + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) # CYGNUS LOCAL + basic_machine=h8500-hitachi + os=-hms + ;; harris) basic_machine=m88k-harris os=-sysv3 @@ -290,6 +363,22 @@ case $basic_machine in basic_machine=m68k-hp os=-hpux ;; + w89k-*) # CYGNUS LOCAL + basic_machine=hppa1.1-winbond + os=-proelf + ;; + op50n-*) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + os=-proelf + ;; + op60c-*) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + os=-proelf + ;; + hppro) # CYGNUS LOCAL + basic_machine=hppa1.1-hp + os=-proelf + ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; @@ -302,27 +391,43 @@ case $basic_machine in hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; + hppaosf) # CYGNUS LOCAL + basic_machine=hppa1.1-hp + os=-osf + ;; i370-ibm* | ibm*) basic_machine=i370-ibm os=-mvs ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? - i[345]86v32) + i[3456]86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` os=-sysv32 ;; - i[345]86v4*) + i[3456]86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` os=-sysv4 ;; - i[345]86v) + i[3456]86v) basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` os=-sysv ;; - i[345]86sol2) + i[3456]86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` os=-solaris2 ;; + i386mach) # CYGNUS LOCAL + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-vsta + ;; + i386-go32 | go32) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-go32 + ;; iris | iris4d) basic_machine=mips-sgi case $os in @@ -357,10 +462,22 @@ case $basic_machine in mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; + monitor) # CYGNUS LOCAL + basic_machine=m68k-rom68k + os=-coff + ;; + msdos) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-msdos + ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; + netbsd386) + basic_machine=i386-unknown # CYGNUS LOCAL + os=-netbsd + ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos @@ -373,6 +490,10 @@ case $basic_machine in basic_machine=mips-sony os=-newsos ;; + necv70) # CYGNUS LOCAL + basic_machine=v70-nec + os=-sysv + ;; next | m*-next ) basic_machine=m68k-next case $os in @@ -398,9 +519,21 @@ case $basic_machine in basic_machine=i960-intel os=-nindy ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; np1) basic_machine=np1-gould ;; + OSE68000 | ose68000) # CYGNUS LOCAL + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) # CYGNUS LOCAL + basic_machine=m68k-none + os=-os68k + ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 @@ -418,14 +551,18 @@ case $basic_machine in pc532 | pc532-*) basic_machine=ns32k-pc532 ;; - pentium | p5 | p6) - # We don't have specific support for the Intel Pentium (p6) followon yet, so just call it a Pentium + pentium | p5) basic_machine=i586-intel ;; - pentium-* | p5-* | p6-*) - # We don't have specific support for the Intel Pentium (p6) followon yet, so just call it a Pentium + pentiumpro | p6) + basic_machine=i686-intel + ;; + pentium-* | p5-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; + pentiumpro-* | p6-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; k5) # We don't have specific support for AMD's K5 yet, so just call it a Pentium basic_machine=i586-amd @@ -452,12 +589,20 @@ case $basic_machine in ps2) basic_machine=i386-ibm ;; + rom68k) # CYGNUS LOCAL + basic_machine=m68k-rom68k + os=-coff + ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; + sa29200) # CYGNUS LOCAL + basic_machine=a29k-amd + os=-udi + ;; sequent) basic_machine=i386-sequent ;; @@ -465,6 +610,10 @@ case $basic_machine in basic_machine=sh-hitachi os=-hms ;; + sparclite-wrs) # CYGNUS LOCAL + basic_machine=sparclite-wrs + os=-vxworks + ;; sps7) basic_machine=m68k-bull os=-sysv2 @@ -472,6 +621,13 @@ case $basic_machine in spur) basic_machine=spur-unknown ;; + st2000) # CYGNUS LOCAL + basic_machine=m68k-tandem + ;; + stratus) # CYGNUS LOCAL + basic_machine=i860-stratus + os=-sysv4 + ;; sun2) basic_machine=m68000-sun ;; @@ -527,6 +683,10 @@ case $basic_machine in basic_machine=a29k-nyu os=-sym1 ;; + v810 | necv810) # CYGNUS LOCAL + basic_machine=v810-nec + os=-none + ;; vaxv) basic_machine=vax-dec os=-sysv @@ -547,6 +707,10 @@ case $basic_machine in basic_machine=a29k-wrs os=-vxworks ;; + w65*) # CYGNUS LOCAL + basic_machine=w65-wdc + os=-none + ;; xmp) basic_machine=xmp-cray os=-unicos @@ -554,6 +718,10 @@ case $basic_machine in xps | xps100) basic_machine=xps100-honeywell ;; + z8k-*-coff) # CYGNUS LOCAL + basic_machine=z8k-unknown + os=-sim + ;; none) basic_machine=none-none os=-none @@ -561,6 +729,15 @@ case $basic_machine in # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. + w89k) # CYGNUS LOCAL + basic_machine=hppa1.1-winbond + ;; + op50n) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + ;; + op60c) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + ;; mips) basic_machine=mips-mips ;; @@ -591,6 +768,12 @@ case $basic_machine in orion105) basic_machine=clipper-highlevel ;; + mac | mpw | mac-mpw) # CYGNUS LOCAL + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) # CYGNUS LOCAL + basic_machine=powerpc-apple + ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 @@ -632,17 +815,27 @@ case $os in # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \ + | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[3456]* \ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \ - | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ + | -amigados* | -msdos* | -moss* | -newsos* | -unicos* | -aos* | -aof* \ + | -nindy* | -mon960* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \ | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* ) + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -cygwin32* | -pe* | -psos*) # Remember, each alternative MUST END IN *, to match a version number. ;; + # CYGNUS LOCAL + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -proelf | -os9* \ + | -macos* | -mpw* | -magic*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + # END CYGNUS LOCAL -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; @@ -664,9 +857,15 @@ case $os in -acis*) os=-aos ;; + -386bsd) # CYGNUS LOCAL + os=-bsd + ;; -ctix* | -uts*) os=-sysv ;; + -ns2 ) + os=-nextstep2 + ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` @@ -692,6 +891,12 @@ case $os in # This must come after -sysvr4. -sysv*) ;; + -ose*) # CYGNUS LOCAL + os=-ose + ;; + -es1800*) # CYGNUS LOCAL + os=-ose + ;; -xenix) os=-xenix ;; @@ -741,6 +946,12 @@ case $basic_machine in # default. # os=-sunos4 ;; + m68*-cisco) # CYGNUS LOCAL + os=-aout + ;; + mips*-cisco) # CYGNUS LOCAL + os=-elf + ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; @@ -750,6 +961,15 @@ case $basic_machine in *-ibm) os=-aix ;; + *-wec) # CYGNUS LOCAL + os=-proelf + ;; + *-winbond) # CYGNUS LOCAL + os=-proelf + ;; + *-oki) # CYGNUS LOCAL + os=-proelf + ;; *-hp) os=-hpux ;; @@ -774,6 +994,9 @@ case $basic_machine in m88k-omron*) os=-luna ;; + *-next ) + os=-nextstep + ;; *-sequent) os=-ptx ;; @@ -807,6 +1030,15 @@ case $basic_machine in *-masscomp) os=-rtu ;; + *-rom68k) # CYGNUS LOCAL + os=-coff + ;; + *-*bug) # CYGNUS LOCAL + os=-coff + ;; + *-apple) # CYGNUS LOCAL + os=-macos + ;; *) os=-none ;; @@ -825,6 +1057,9 @@ case $basic_machine in -sunos*) vendor=sun ;; + -bosx*) # CYGNUS LOCAL + vendor=bull + ;; -lynxos*) vendor=lynx ;; @@ -858,6 +1093,15 @@ case $basic_machine in -vxworks*) vendor=wrs ;; + -aux*) + vendor=apple + ;; + -hms*) # CYGNUS LOCAL + vendor=hitachi + ;; + -mpw* | -macos*) # CYGNUS LOCAL + vendor=apple + ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; diff --git a/configure.in b/configure.in index c3f058c3ff..3a57a3cc93 100644 --- a/configure.in +++ b/configure.in @@ -17,7 +17,8 @@ AC_INIT(STARTUP.in) # # Prepare to generate the following header files # -AC_CONFIG_HEADER(ghc/includes/config.h literate/config.h) +AC_CONFIG_HEADER(ghc/includes/config.h) +# and literate/config.h ??? # ToDo !!!!!!!!!!!!!!!! # # No, we don't do `--srcdir'... @@ -27,15 +28,16 @@ if test x"$srcdir" != 'x.' ; then fi # ------------------------------------------------------------------------- -dnl ** choose what blobs to build (ghc,haggis,happy,nofib,????) +dnl ** choose what blobs to build (ghc,hslibs,haggis,happy,nofib,????) # set to the name for the dir if doing it, otherwise empty DoingGHC='ghc' +DoingHsLibs='' DoingNoFib='' DoingHappy='' DoingHaggis='' +DoingLiterate='' # the following are not normally changed -DoingLiterate='literate' DoingMkWorld='mkworld' DoingGlaFpUtils='glafp-utils' @@ -48,7 +50,7 @@ AC_ARG_ENABLE(ghc, ********************************************************************** First, select *which* of the tools you want to build, -with --{enable,disable}-{ghc,nofib,happy,haggis}. +with --{enable,disable}-{ghc,hslibs,nofib,happy,haggis}. (The default is: only GHC (Glasgow Haskell compiler).) Second, you may set one of a few applies-in-all-cases options. @@ -91,6 +93,26 @@ if test "xxx$DoingGHC" = 'xxx' ; then # ghc_includes_config_h='' fi +AC_ARG_ENABLE(hslibs, + [--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 +hslibs_mkworld_site_hslibs_jm='hslibs/mkworld/site-hslibs.jm' +if test "xxx$DoingHsLibs" = 'xxx' ; then + hslibs_mkworld_site_hslibs_jm='' +fi + AC_ARG_ENABLE(nofib, [--enable-nofib build NoFib suite as part of Glasgow FP tools], [case "$enableval" in @@ -128,7 +150,7 @@ if test "xxx$DoingHappy" = 'xxxhappy' -a \( ! -d happy \) ; then fi AC_ARG_ENABLE(haggis, - [--disable-haggis build Haggis GUI toolkit as part of Glasgow FP tools], + [--enable-haggis build Haggis GUI toolkit as part of Glasgow FP tools], [case "$enableval" in yes) DoingHaggis='haggis' ;; @@ -194,6 +216,7 @@ if test "xxx$DoingGlaFpUtils" = 'xxxglafp-utils' -a \( ! -d glafp-utils \) ; the fi AC_SUBST(DoingGHC) +AC_SUBST(DoingHsLibs) AC_SUBST(DoingNoFib) AC_SUBST(DoingHappy) AC_SUBST(DoingHaggis) @@ -207,7 +230,7 @@ dnl ** choose host(/target/build) platform # Partly stolen from GCC "configure". # if test "x$target" = xNONE ; then - if test "x$nonopt" != xNONE; then + if test "x$nonopt" != xNONE ; then target=$nonopt else # This way of testing the result of a command substitution is @@ -217,8 +240,7 @@ if test "x$target" = xNONE ; then else echo 'Config.guess failed to determine the host type. You need \ to specify one.' 1>&2 - if [ -r config.status ] - then + if test -r config.status ; then tail +2 config.status 1>&2 fi exit 1 @@ -254,7 +276,7 @@ fi # We also record the architecture, vendor, and operating system (OS) # separately. case $HostPlatform in -alpha-dec-osf1* | alpha-dec-osf2*) +alpha-dec-osf[[1234]]*) HostPlatform=alpha-dec-osf1 # canonicalise for our purposes TargetPlatform=alpha-dec-osf1 # this will work for now... (hack) BuildPlatform=alpha-dec-osf1 #hack @@ -272,7 +294,7 @@ hppa1.1-hp-hpux*) HostVendor_CPP='hp' HostOS_CPP='hpux' ;; -i386-*-linuxaout*) +i[[3456]]86-*-linuxaout*) HostPlatform=i386-unknown-linuxaout # hack again TargetPlatform=i386-unknown-linuxaout BuildPlatform=i386-unknown-linuxaout @@ -281,16 +303,7 @@ i386-*-linuxaout*) HostVendor_CPP='unknown' HostOS_CPP='linuxaout' ;; -i486-*-linuxaout*) - HostPlatform=i386-unknown-linuxaout # hack again: NB: name for arch is *i386*! - TargetPlatform=i386-unknown-linuxaout - BuildPlatform=i386-unknown-linuxaout - HostPlatform_CPP='i386_unknown_linuxaout' - HostArch_CPP='i386' - HostVendor_CPP='unknown' - HostOS_CPP='linuxaout' - ;; -i386-*-linux*) +i[[3456]]86-*-linux*) HostPlatform=i386-unknown-linux # hack again TargetPlatform=i386-unknown-linux BuildPlatform=i386-unknown-linux @@ -299,40 +312,25 @@ i386-*-linux*) HostVendor_CPP='unknown' HostOS_CPP='linux' ;; -i486-*-linux*) - HostPlatform=i386-unknown-linux # hack again: NB: name for arch is *i386*! - TargetPlatform=i386-unknown-linux - BuildPlatform=i386-unknown-linux - HostPlatform_CPP='i386_unknown_linux' - HostArch_CPP='i386' - HostVendor_CPP='unknown' - HostOS_CPP='linux' - ;; -i386-*-freebsd*) - HostPlatform_CPP='i386_unknown_freebsd' - HostArch_CPP='i386' - HostVendor_CPP='unknown' - HostOS_CPP='freebsd' - ;; -i486-*-freebsd*) +i[[3456]]86-*-freebsd*) + HostPlatform=i386-unknown-freebsd # hack again + TargetPlatform=i386-unknown-freebsd + BuildPlatform=i386-unknown-freebsd HostPlatform_CPP='i386_unknown_freebsd' HostArch_CPP='i386' HostVendor_CPP='unknown' HostOS_CPP='freebsd' ;; -i386-*-netbsd*) +i[[3456]]86-*-netbsd*) + HostPlatform=i386-unknown-netbsd # hack again + TargetPlatform=i386-unknown-netbsd + BuildPlatform=i386-unknown-netbsd HostPlatform_CPP='i386_unknown_netbsd' HostArch_CPP='i386' HostVendor_CPP='unknown' HostOS_CPP='netbsd' ;; -i486-*-netbsd*) - HostPlatform_CPP='i386_unknown_netbsd' - HostArch_CPP='i386' - HostVendor_CPP='unknown' - HostOS_CPP='netbsd' - ;; -i386-*-solaris2*) +i[[3456]]86-*-solaris2*) HostPlatform=i386-unknown-solaris2 # hack again TargetPlatform=i386-unknown-solaris2 BuildPlatform=i386-unknown-solaris2 @@ -353,7 +351,7 @@ m68k-next-nextstep3) HostVendor_CPP='next' HostOS_CPP='nextstep3' ;; -i386-next-nextstep3) +i[[3456]]86-next-nextstep3) HostPlatform=i386-next-nextstep3 # hack again TargetPlatform=i386-next-nextstep3 BuildPlatform=i386-next-nextstep3 @@ -617,6 +615,10 @@ if test -z "$YaccCmd"; then fi fi +dnl ** Find lex command (lex or flex) and library (-ll or -lfl) +# +AC_PROG_LEX + #-------------------------------------------------------------- WithHc='haskell-compiler-unspecified' WithHcType='HC_UNSPECIFIED' @@ -689,14 +691,37 @@ 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 -r') +MakeCmd='make -r' +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). You probably want to include the '-r' flag with + make, to exclude implicit suffix rules.], + [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).], + [ +--with-tmpdir=<temp directory> + Use an alternative directory for temporary files (presumably + because /tmp is too small).], [TmpDir="$withval"]) AC_SUBST(TmpDir) @@ -707,8 +732,9 @@ HcMaxHeapWasSet='NO' HcMaxHeap='0' AC_ARG_WITH(max-heap, [ ---with-max-heap=<heap size, e.g., 32m> Do all Haskell compilations -with a heap of this size. (If you've got it, flaunt it.)], +--with-max-heap=<heap size, e.g., 32m> + Do all Haskell compilations with a heap of this size. (If + you've got it, flaunt it.)], [HcMaxHeapWasSet='YES' HcMaxHeap="$withval"]) AC_SUBST(HcMaxHeapWasSet) @@ -769,6 +795,9 @@ elif $ArCmd clq conftest.a >/dev/null 2>/dev/null; then elif $ArCmd cq conftest.a >/dev/null 2>/dev/null; then ArCmd="$ArCmd cq" NeedRanLib='YES' +elif $ArCmd cq conftest.a 2>&1 | grep 'no archive members specified' >/dev/null 2>/dev/null; then + ArCmd="$ArCmd cq" + NeedRanLib='YES' else echo "I can't figure out how to use your $ArCmd" exit 1 @@ -815,21 +844,6 @@ dnl ** determine the type of signal() # AC_TYPE_SIGNAL # -dnl ** decide whether or not flex lexers need to be linked with -lfl -# -AC_CHECK_LIB(fl,yywrap, - FlexLibAvailable='YES', - FlexLibAvailable='NO') -AC_SUBST(FlexLibAvailable) -# -dnl ** Decide whether or not lex lexers need to be linked with -ll -# (Linux, for example, does not have "lex", only "flex") -# -AC_CHECK_LIB(l,yywrap, - LexLibAvailable='YES', - LexLibAvailable='NO') -AC_SUBST(LexLibAvailable) -# dnl ** check for specific library functions that we are interested in # AC_CHECK_FUNCS(access ftime getclock getpagesize getrusage gettimeofday mktime mprotect setitimer stat sysconf timelocal times vadvise vfork) @@ -1047,224 +1061,226 @@ AC_ARG_ENABLE(gc-du, ;; esac]) -dnl some seds only allow 99 commands, meaning no more -dnl than 99 AC_SUBSTs. AARRGGHH!! -dnl AC_ARG_ENABLE(user-way-a, -dnl [--enable-user-way-a build for \`user way a' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_a='YES' -dnl ;; -dnl no) GhcBuild_a='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-a=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-b, -dnl [--enable-user-way-b build for \`user way b' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_b='YES' -dnl ;; -dnl no) GhcBuild_b='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-b=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-c, -dnl [--enable-user-way-c build for \`user way c' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_c='YES' -dnl ;; -dnl no) GhcBuild_c='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-c=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-d, -dnl [--enable-user-way-d build for \`user way d' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_d='YES' -dnl ;; -dnl no) GhcBuild_d='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-d=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-e, -dnl [--enable-user-way-e build for \`user way e' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_e='YES' -dnl ;; -dnl no) GhcBuild_e='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-e=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-f, -dnl [--enable-user-way-f build for \`user way f' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_f='YES' -dnl ;; -dnl no) GhcBuild_f='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-f=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-g, -dnl [--enable-user-way-g build for \`user way g' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_g='YES' -dnl ;; -dnl no) GhcBuild_g='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-g=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-h, -dnl [--enable-user-way-h build for \`user way h' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_h='YES' -dnl ;; -dnl no) GhcBuild_h='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-h=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-i, -dnl [--enable-user-way-i build for \`user way i' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_i='YES' -dnl ;; -dnl no) GhcBuild_i='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-i=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-j, -dnl [--enable-user-way-j build for \`user way j' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_j='YES' -dnl ;; -dnl no) GhcBuild_j='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-j=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-k, -dnl [--enable-user-way-k build for \`user way k' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_k='YES' -dnl ;; -dnl no) GhcBuild_k='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-k=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-l, -dnl [--enable-user-way-l build for \`user way l' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_l='YES' -dnl ;; -dnl no) GhcBuild_l='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-l=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-m, -dnl [--enable-user-way-m build for \`user way m' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_m='YES' -dnl ;; -dnl no) GhcBuild_m='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-m=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-n, -dnl [--enable-user-way-n build for \`user way n' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_n='YES' -dnl ;; -dnl no) GhcBuild_n='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-n=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-o, -dnl [--enable-user-way-o build for \`user way o' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_o='YES' -dnl ;; -dnl no) GhcBuild_o='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-o=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-A, -dnl [--enable-user-way-A build for \`user way A' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_A='YES' -dnl ;; -dnl no) GhcBuild_A='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-A=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -dnl AC_ARG_ENABLE(user-way-B, -dnl [--enable-user-way-B build for \`user way B' (mostly for implementors)], -dnl [case "$enableval" in -dnl yes) GhcBuild_B='YES' -dnl ;; -dnl no) GhcBuild_B='NO' -dnl ;; -dnl *) echo "I don't understand this option: --enable-user-way-B=$enableval" -dnl exit 1 -dnl ;; -dnl esac]) -dnl -AC_SUBST(GhcBuild_normal) -AC_SUBST(GhcBuild_p) -AC_SUBST(GhcBuild_t) -AC_SUBST(GhcBuild_u) -AC_SUBST(GhcBuild_mc) -AC_SUBST(GhcBuild_mr) -AC_SUBST(GhcBuild_mt) -AC_SUBST(GhcBuild_mp) -AC_SUBST(GhcBuild_mg) -AC_SUBST(GhcBuild_2s) -AC_SUBST(GhcBuild_1s) -AC_SUBST(GhcBuild_du) +AC_ARG_ENABLE(user-way-a, + [--enable-user-way-a build for \`user way a' (mostly for implementors)], + [case "$enableval" in + yes) GhcBuild_a='YES' + ;; + no) GhcBuild_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) GhcBuild_b='YES' + ;; + no) GhcBuild_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) GhcBuild_c='YES' + ;; + no) GhcBuild_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) GhcBuild_d='YES' + ;; + no) GhcBuild_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) GhcBuild_e='YES' + ;; + no) GhcBuild_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) GhcBuild_f='YES' + ;; + no) GhcBuild_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) GhcBuild_g='YES' + ;; + no) GhcBuild_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) GhcBuild_h='YES' + ;; + no) GhcBuild_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) GhcBuild_i='YES' + ;; + no) GhcBuild_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) GhcBuild_j='YES' + ;; + no) GhcBuild_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) GhcBuild_k='YES' + ;; + no) GhcBuild_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) GhcBuild_l='YES' + ;; + no) GhcBuild_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) GhcBuild_m='YES' + ;; + no) GhcBuild_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) GhcBuild_n='YES' + ;; + no) GhcBuild_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) GhcBuild_o='YES' + ;; + no) GhcBuild_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) GhcBuild_A='YES' + ;; + no) GhcBuild_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) GhcBuild_B='YES' + ;; + no) GhcBuild_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 GhcBuild_* info, +dnl as some seds (notably OSF) only allow 99 commands (!!!). +dnl We will do the equivalent by a HACK further down. + +dnl AC_SUBST(GhcBuild_normal) +dnl AC_SUBST(GhcBuild_p) +dnl AC_SUBST(GhcBuild_t) +dnl AC_SUBST(GhcBuild_u) +dnl AC_SUBST(GhcBuild_mc) +dnl AC_SUBST(GhcBuild_mr) +dnl AC_SUBST(GhcBuild_mt) +dnl AC_SUBST(GhcBuild_mp) +dnl AC_SUBST(GhcBuild_mg) +dnl AC_SUBST(GhcBuild_2s) +dnl AC_SUBST(GhcBuild_1s) +dnl AC_SUBST(GhcBuild_du) dnl AC_SUBST(GhcBuild_a) dnl AC_SUBST(GhcBuild_b) dnl AC_SUBST(GhcBuild_c) @@ -1291,7 +1307,7 @@ dnl ** which Haskell compiler to bootstrap GHC with? # first, the defaults... WithGhcHc='haskell-compiler-unspecified' WithGhcHcType='HC_UNSPECIFIED' -GhcBuilderVersion='26' +GhcBuilderVersion='28' AC_ARG_WITH(hc-for-ghc, [ @@ -1534,9 +1550,100 @@ AC_ARG_ENABLE(ghci, esac]) AC_SUBST(BuildGHCI) +# Here, by HACK means, we dump all the GhcBuild_ info +# into a file. See comment above. +rm -f ghc/mkworld/buildinfo.jm +echo creating ghc/mkworld/buildinfo.jm +cat > ghc/mkworld/buildinfo.jm <<EOF +XCOMM ** DO NOT EDIT! ** +XCOMM 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=\$GhcBuild_$xx" + echo "#ifndef GhcBuild_$xx" >> ghc/mkworld/buildinfo.jm + echo "#define GhcBuild_$xx $yy" >> ghc/mkworld/buildinfo.jm + echo "#endif" >> ghc/mkworld/buildinfo.jm +done + # here ends a very big if DoingGHC = 'ghc' ... fi +# ------------------------------------------------------------------------- +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' + ;; +esac +AC_SUBST(WithHsLibsHc) +AC_SUBST(WithHsLibsHcType) + +# Here, by HACK means, we dump all the GhcBuild_ info +# into a file. See comment above. +rm -f hslibs/mkworld/buildinfo.jm +echo creating hslibs/mkworld/buildinfo.jm +cat > hslibs/mkworld/buildinfo.jm <<EOF +XCOMM ** DO NOT EDIT! ** +XCOMM This file is obliterated every time 'configure' is run! + +EOF +dnl Do not really know what to put here: +dnl 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 +dnl eval "yy=\$GhcBuild_$xx" +dnl echo "#ifndef GhcBuild_$xx" >> ghc/mkworld/buildinfo.jm +dnl echo "#define GhcBuild_$xx $yy" >> ghc/mkworld/buildinfo.jm +dnl echo "#endif" >> ghc/mkworld/buildinfo.jm +dnl done + +# here ends a very big if DoingHsLibs = 'hslibs' ... +fi # # ------------------------------------------------------------------------- dnl @@ -1816,8 +1923,7 @@ fi IncludeRealNoFibTests='YES' # defaults IncludeSpectralNoFibTests='YES' IncludeImaginaryNoFibTests='YES' -IncludePENDINGNoFibTests='NO' -IncludeUNUSEDNoFibTests='NO' +IncludeSpecialiseNoFibTests='NO' IncludeGHC_ONLYNoFibTests='NO' IncludePRIVATENoFibTests='NO' IncludeParallelNoFibTests='NO' @@ -1830,15 +1936,13 @@ only if using GHC): --enable-all-tests do *all* tests], [case "$enableval" in - yes) IncludePENDINGNoFibTests='YES' - IncludeUNUSEDNoFibTests='YES' - IncludeGHC_ONLYNoFibTests='YES' + yes) IncludeGHC_ONLYNoFibTests='YES' + IncludeSpecialiseNoFibTests='YES' IncludePRIVATENoFibTests='YES' IncludeParallelNoFibTests='YES' ;; - no) IncludePENDINGNoFibTests='NO' - IncludeUNUSEDNoFibTests='NO' - IncludeGHC_ONLYNoFibTests='NO' + no) IncludeGHC_ONLYNoFibTests='NO' + IncludeSpecialiseNoFibTests='NO' IncludePRIVATENoFibTests='NO' IncludeParallelNoFibTests='NO' @@ -1892,38 +1996,26 @@ AC_ARG_ENABLE(real-tests, ;; esac]) -AC_ARG_ENABLE(PENDING-tests, - [--enable-PENDING-tests include PENDING tests], - [case "$enableval" in - yes) IncludePENDINGNoFibTests='YES' - ;; - no) IncludePENDINGNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-PENDING-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(UNUSED-tests, - [--enable-UNUSED-tests include UNUSED tests], +AC_ARG_ENABLE(GHC-ONLY-tests, + [--enable-GHC-ONLY-tests include GHC_ONLY tests], [case "$enableval" in - yes) IncludeUNUSEDNoFibTests='YES' + yes) IncludeGHC_ONLYNoFibTests='YES' ;; - no) IncludeUNUSEDNoFibTests='NO' + no) IncludeGHC_ONLYNoFibTests='NO' ;; - *) echo "I don't understand this option: --enable-UNUSED-tests=$enableval" + *) echo "I don't understand this option: --enable-GHC-ONLY-tests=$enableval" exit 1 ;; esac]) -AC_ARG_ENABLE(GHC-ONLY-tests, - [--enable-GHC-ONLY-tests include GHC_ONLY tests], +AC_ARG_ENABLE(specialise-tests, + [--enable-specialise-tests include specialisation tests], [case "$enableval" in - yes) IncludeGHC_ONLYNoFibTests='YES' + yes) IncludeSpecialiseNoFibTests='YES' ;; - no) IncludeGHC_ONLYNoFibTests='NO' + no) IncludeSpecialiseNoFibTests='NO' ;; - *) echo "I don't understand this option: --enable-GHC-ONLY-tests=$enableval" + *) echo "I don't understand this option: --enable-specialise-tests=$enableval" exit 1 ;; esac]) @@ -1953,15 +2045,31 @@ AC_ARG_ENABLE(parallel-tests, ;; esac]) -AC_SUBST(IncludeRealNoFibTests) -AC_SUBST(IncludeSpectralNoFibTests) -AC_SUBST(IncludeImaginaryNoFibTests) -AC_SUBST(IncludePENDINGNoFibTests) -AC_SUBST(IncludeUNUSEDNoFibTests) -AC_SUBST(IncludeGHC_ONLYNoFibTests) -AC_SUBST(IncludeSpecialiseNoFibTests) -AC_SUBST(IncludePRIVATENoFibTests) -AC_SUBST(IncludeParallelNoFibTests) +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/mkworld/buildinfo.jm +echo creating nofib/mkworld/buildinfo.jm +cat > nofib/mkworld/buildinfo.jm <<EOF +XCOMM ** DO NOT EDIT! ** +XCOMM 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 "#ifndef Include${xx}NoFibTests" >> nofib/mkworld/buildinfo.jm + echo "#define Include${xx}NoFibTests $yy" >> nofib/mkworld/buildinfo.jm + echo "#endif" >> nofib/mkworld/buildinfo.jm +done # here ends a very big if DoingNoFib = 'nofib' ... fi @@ -1972,7 +2080,7 @@ dnl * extract non-header files with substitution (end) # AC_SUBST(MkWorldSetup) -AC_OUTPUT(Makefile STARTUP mkworld/site.jm mkworld/platform.h mkworld/config.h $ghc_mkworld_site_ghc_jm $ghc_includes_platform_h $nofib_mkworld_site_nofib_jm) +AC_OUTPUT(Makefile STARTUP mkworld/site.jm mkworld/platform.h mkworld/config.h $ghc_mkworld_site_ghc_jm $ghc_includes_platform_h $hslibs_mkworld_site_hslibs_jm $nofib_mkworld_site_nofib_jm) echo '************************************************' echo '*** NOW DO: sh < STARTUP' diff --git a/ghc/Jmakefile b/ghc/Jmakefile index e2d68ee3e4..f6bae9dd73 100644 --- a/ghc/Jmakefile +++ b/ghc/Jmakefile @@ -1,7 +1,5 @@ #define IHaveSubdirs -MsubNeededHere( ./glue_TAGS_files ) - /* order in SUBDIRS is not supposed to be important but ... "compiler" must be before "lib", because we use the compiler just built to compile pieces of "lib". @@ -38,10 +36,3 @@ SUBDIRS = includes \ whoami:: @echo using a \`$(BUILDPLATFORM)\' host to build a Haskell compiler to run on a @echo \`$(HOSTPLATFORM)\' host that will generate \`C\' target code - -fulltags : ./glue_TAGS_files - $(RM) ./TAGS - ./glue_TAGS_files `find . -type f -name TAGS -print` - -/* this line makes sure perl gets picked up from the right place */ -MsubProgramScriptTarget(PerlCmd,./glue_TAGS_files,./glue_TAGS_files.prl,,) diff --git a/ghc/Makefile.BOOT b/ghc/Makefile.BOOT index 8d0e797293..72b7dbf179 100644 --- a/ghc/Makefile.BOOT +++ b/ghc/Makefile.BOOT @@ -40,7 +40,7 @@ JMAKE_CMD = $(NEWTOP)$(JMAKE) -I$(NEWTOP)$(JMAKESRC) $(BOOTSTRAPCFLAGS) -DTopDir Makefile:: $(JMAKE) $(JMAKE): - @(cd $(JMAKESRC); if [ -f Makefile ]; then \ + @(cd $(JMAKESRC) && if [ -f Makefile ]; then \ echo "checking $@ in $(JMAKESRC) first..."; $(MAKE) all; else \ echo "bootstrapping $@ from Makefile.BOOT in $(JMAKESRC) first..."; \ $(MAKE) -f Makefile.BOOT BOOTSTRAPCFLAGS=$(BOOTSTRAPCFLAGS); fi; \ diff --git a/ghc/PATCHLEVEL b/ghc/PATCHLEVEL index 936caf5f01..916eaba418 100644 --- a/ghc/PATCHLEVEL +++ b/ghc/PATCHLEVEL @@ -1 +1,2 @@ -The Glamorous Glasgow Haskell Compiler, version 0.27, patchlevel 0 +The Glamorous Glasgow Haskell Compiler, version 2.01, patchlevel 0 +(for Haskell 1.3) diff --git a/ghc/README b/ghc/README index ccc3edbbba..ea726dfa14 100644 --- a/ghc/README +++ b/ghc/README @@ -1,6 +1,6 @@ -This is version 0.26 of the Glorious Glasgow Haskell compilation +This is version 2.01 of the Glorious Glasgow Haskell compilation system (GHC). This is a major public release. The top-level file -"ANNOUNCE-0.26" says more. +"ANNOUNCE-0.28" says more. Haskell is "the" standard lazy functional programming language [see SIGPLAN Notices, May 1992]. Some general merits of GHC are given at diff --git a/ghc/docs/Jmakefile b/ghc/docs/Jmakefile index 799f3e05d2..9e9510cac4 100644 --- a/ghc/docs/Jmakefile +++ b/ghc/docs/Jmakefile @@ -2,6 +2,7 @@ /* just documents here */ #define NoAllTargetForSubdirs +#define NoDependTargetForSubdirs #define NoRunTestsTargetForSubdirs #define NoInstallTargetForSubdirs #define NoTagTargetForSubdirs diff --git a/ghc/docs/install_guide/installing.lit b/ghc/docs/install_guide/installing.lit index 13df5b500a..5cdd18995b 100644 --- a/ghc/docs/install_guide/installing.lit +++ b/ghc/docs/install_guide/installing.lit @@ -1,5 +1,5 @@ % -% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/install_guide/Attic/installing.lit,v 1.1 1996/01/08 20:25:19 partain Exp $ +% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/install_guide/Attic/installing.lit,v 1.2 1996/06/27 15:57:32 partain Exp $ % \begin{onlystandalone} \documentstyle[11pt,literate]{article} @@ -12,7 +12,7 @@ University of Glasgow\\ Glasgow, Scotland\\ G12 8QQ\\ \\ -Email: glasgow-haskell-\{request,bugs\}\@dcs.glasgow.ac.uk} +Email: glasgow-haskell-\{users,bugs\}-request\@dcs.glasgow.ac.uk} \maketitle \begin{rawlatex} \tableofcontents diff --git a/ghc/docs/release_notes/release.lit b/ghc/docs/release_notes/release.lit index 16e4d24062..b98df34d3e 100644 --- a/ghc/docs/release_notes/release.lit +++ b/ghc/docs/release_notes/release.lit @@ -8,7 +8,7 @@ University of Glasgow\\ Glasgow, Scotland\\ G12 8QQ\\ \\ -Email: glasgow-haskell-\{bugs,request\}\@dcs.glasgow.ac.uk} +Email: glasgow-haskell-\{users,bugs\}-request\@dcs.glasgow.ac.uk} \maketitle \begin{rawlatex} \tableofcontents diff --git a/ghc/docs/state_interface/state-interface.verb b/ghc/docs/state_interface/state-interface.verb index 37672055c8..c51193aa97 100644 --- a/ghc/docs/state_interface/state-interface.verb +++ b/ghc/docs/state_interface/state-interface.verb @@ -349,8 +349,8 @@ 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 StateAndMallocPtr# s = StateAndMallocPtr# (State# s) MallocPtr# +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) @@ -461,47 +461,68 @@ deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWor @ There is also a C procedure @FreeStablePtr@ which frees a stable pointer. -\subsubsection{``Malloc'' pointers} +% +% Rewritten and updated for MallocPtr++ -- 4/96 SOF +% +\subsubsection{Foreign objects} -A ``malloc'' pointer is an ordinary pointer from outside the Haskell world -(i.e., from the C world) where the Haskell world has been told ``Let me +A \tr{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 ``malloc'' pointer type is just a special @Addr#@ ({\em not} parameterised). +The \tr{ForeignObj} type is just a special @Addr#@ ({\em not} parameterised). @ -type MallocPtr# +type ForeignObj# @ -{\em ToDo: say more about this and how it's used...} -The main point is that when Haskell discards a -value of type @MallocPtr#@, it calls the procedure @FreeMallocPtr@, which -must be provided by the C world. @FreeMallocPtr@ might in turn call -the GHC-provided procedure @FreeStablePtr@, to deallocate a stable pointer. -No other GHC runtime system procedures should be called by @FreeMallocPtr@. +A typical use of \tr{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 \tr{ForeignObj}'s precursor, \tr{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. -(Implementation: a linked list of all @MallocPtr#@s is maintained to allow the -garbage collector to detect when a @MallocPtr#@ becomes garbage.) +@ +data Image = Image ForeignObj# -Like @Array@, @MallocPtr#@s are represented by heap objects. +instance _CCallable Image +@ -{\bf ToDo --- Important:} Ian Poole reports a need for functions to return a list of -CHPs. Should we add a @CHeapPtrArray@ type too? or just -hack something up? +The \tr{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 \tr{ForeignObj#} is +used to ``box'' up an external reference into a Haskell heap object +that we can then indirectly reference: -The only Haskell operation we might want on @MallocPtr#@s is an -equality test. However, this is easily implemented if desired: @ -> eqCHP x y = (_runST (_ccall_ equal x y) == 1::Int) +createImage :: (Int,Int) -> PrimIO Image +@ + +So far, this looks just like an @Addr#@ type, but \tr{ForeignObj#} +offers a bit more, namely that we can specify a {\em finalisation +routine} to invoke when the \tr{ForeignObj#} is discarded by the +GC. The garbage collector invokes the finalisation routine associated +with the \tr{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.). -C> equal (x, y) -C> { -C> return (x == y ? 1 : 0); -C> } +Associating a finalisation routine with an external object is done by +\tr{makeForeignObj#}: + +@ +makeForeignObj# :: Addr# -- foreign reference + -> Addr# -- pointer to finalisation routine + -> StateAndForeignObj# _RealWorld ForeignObj# @ -The C world must provide a function @FreeCHeapPointer@ which -will be called (with a C Heap pointer as argument) when the garbage -collector releases a CHP. +(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 @@ -803,14 +824,14 @@ 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 Char) +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 elt) +unsafeFreezeByteArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix) @ Sometimes we want to snaffle the bounds of one of these beasts: @@ -854,11 +875,13 @@ makeStablePointer :: a -> _StablePtr a freeStablePointer :: _StablePtr a -> PrimIO () @ -\subsection{``Malloc'' pointers} +\subsection{Foreign objects} Again, just boxing up. @ -data _MallocPtr = _MallocPtr MallocPtr# +data _ForeignObj = _ForeignObj ForeignObj# + +makeForeignObj :: _Addr -> _Addr -> PrimIO _ForeignObj @ \subsection{C calls} @@ -899,22 +922,22 @@ 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 +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 -_MallocPtr MallocPtr# StgMallocPtr StgPtr +_StablePtr StablePtr# StgStablePtr StgPtr +_ForeignObj ForeignObj# StgForeignObj StgPtr @ All of the above are {\em C-returnable} except: @@ -959,8 +982,10 @@ 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#@. +% +%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} @@ -977,7 +1002,7 @@ data Integer = J# Int# Int# ByteArray# -- and the other boxed-primitive types: Array, _ByteArray, _MutableArray, _MutableByteArray, - _StablePtr, _MallocPtr + _StablePtr, _ForeignObj data Bool = False | True data CMP_TAG# = LT# | EQ# | GT# -- used in derived comparisons diff --git a/ghc/docs/users_guide/gone_wrong.lit b/ghc/docs/users_guide/gone_wrong.lit index 4403d203f9..960d3b7f36 100644 --- a/ghc/docs/users_guide/gone_wrong.lit +++ b/ghc/docs/users_guide/gone_wrong.lit @@ -52,7 +52,7 @@ This is a bug just as surely as a ``panic.'' Please report it. \item[``Some confusion about a value specialised to a type...'' Huh???] (A deeply obscure and unfriendly error message.) -This message crops up when the typechecker is sees a reference in an +This message crops up when the typechecker sees a reference in an interface pragma to a specialisation of an overloaded value (function); for example, \tr{elem} specialised for type \tr{[Char]} (\tr{String}). The problem is: it doesn't {\em know} that such a diff --git a/ghc/docs/users_guide/prof-compiler-options.lit b/ghc/docs/users_guide/prof-compiler-options.lit index 21d8ca6965..0f870b431f 100644 --- a/ghc/docs/users_guide/prof-compiler-options.lit +++ b/ghc/docs/users_guide/prof-compiler-options.lit @@ -53,6 +53,12 @@ declared in the module. If no group is specified it defaults to the module name. \end{description} +In addition to the \tr{-prof} option your system might be setup to +enable you to compile and link with the \tr{-prof-details} +\index{\tr{-prof-details option}} option instead. This enables +additional detailed counts to be reported with the \tr{-P} RTS option. +%-prof-details should also enable age profiling if we get it going again ... + %Alternative profiling semantics have also been implemented. To use %these the runtime system and prelude libraries must have been built %for the alternative profiling setup. This is done using a particular diff --git a/ghc/docs/users_guide/prof-output.lit b/ghc/docs/users_guide/prof-output.lit index a246b382cc..868c98c47a 100644 --- a/ghc/docs/users_guide/prof-output.lit +++ b/ghc/docs/users_guide/prof-output.lit @@ -3,7 +3,7 @@ % When you run your profiled program with the \tr{-p} RTS option -\index{\tr{-p<sort> RTS option (profiling)}, you get the following +\index{\tr{-p<sort> RTS option (profiling)}}, you get the following information about your ``cost centres'': \begin{description} @@ -19,12 +19,6 @@ different modules. How many times this cost-centre was entered; think of it as ``I got to the \tr{_scc_} construct this many times...'' %------------------------------------------------------------- -\item[\tr{subcc}:] -How many times this cost-centre ``passed control'' to another -cost-centre; for example, \tr{scc=4} plus \tr{subscc=8} means -``This \tr{_scc_} was entered four times, but went out to -other \tr{_scc_s} eight times.'' -%------------------------------------------------------------- \item[\tr{%time}:] What part of the time was spent in this cost-centre (see also ``ticks,'' below). @@ -32,18 +26,43 @@ below). \item[\tr{%alloc}:] What part of the memory allocation was done in this cost-centre (see also ``bytes,'' below). +%------------------------------------------------------------- +\item[\tr{inner}:] +How many times this cost-centre ``passed control'' to an inner +cost-centre; for example, \tr{scc=4} plus \tr{subscc=8} means +``This \tr{_scc_} was entered four times, but went out to +other \tr{_scc_s} eight times.'' +%------------------------------------------------------------- +\item[\tr{cafs}:] +How many CAFs this cost centre evaluated. +%------------------------------------------------------------- +\item[\tr{dicts}:] +How many dictionaries this cost centre evaluated. +\end{description} + +In addition you can use the \tr{-P} RTS option \index{\tr{-P<sort> RTS + option (profiling)}} to get the following additional information: +\begin{description} +%------------------------------------------------------------- +\item[\tr{ticks}:] The raw number of time ``ticks'' which were +attributed to this cost-centre; from this, we get the \tr{%time} +figure mentioned above. +%------------------------------------------------------------- +\item[\tr{bytes}:] Number of bytes allocated in the heap while in +this cost-centre; again, this is the raw number from which we +get the \tr{%alloc} figure mentioned above. \end{description} -If you use the \tr{-P} RTS option -\index{\tr{-P<sort> RTS option (profiling)}, you will also get the -following information: +Finally if you built your program with \tr{-prof-details} +\index{\tr{-prof-details option}} the \tr{-P} RTS option will also +produce the following information: \begin{description} %------------------------------------------------------------- -\item[\tr{cafcc}:] Two columns, analogous to the \tr{scc} and \tr{subcc} -columns, except these are for CAF cost-centres: the first column -is how many times this top-level CAF cost-centre was entered; -the second column is how many times this cost-centre (CAF or otherwise) -entered another CAF cost-centre. +\item[\tr{closures}:] +How many heap objects were allocated; these objects may be of varying +size. If you divide the number of bytes (mentioned below) by this +number of ``closures'', then you will get the average object size. +(Not too interesting, but still...) %------------------------------------------------------------- \item[\tr{thunks}:] How many times we entered (evaluated) a thunk---an unevaluated @@ -60,18 +79,4 @@ How many times we entered (evaluated) a partial application (PAP), i.e., a function applied to fewer arguments than it needs. For example, \tr{Int} addition applied to one argument would be a PAP. A PAP is really just a particular form for a function. -%------------------------------------------------------------- -\item[\tr{closures}:] -How many heap objects were allocated; these objects may be of varying -size. If you divide the number of bytes (mentioned below) by this -number of ``closures'', then you will get the average object size. -(Not too interesting, but still...) -%------------------------------------------------------------- -\item[\tr{ticks}:] The raw number of time ``ticks'' which were -attributed to this cost-centre; from this, we get the \tr{%time} -figure mentioned above. -%------------------------------------------------------------- -\item[\tr{bytes}:] Number of bytes allocated in the heap while in -this cost-centre; again, this is the raw number from which we -get the \tr{%alloc} figure mentioned above. \end{description} diff --git a/ghc/docs/users_guide/prof-rts-options.lit b/ghc/docs/users_guide/prof-rts-options.lit index 022d4e3172..12325d5ba0 100644 --- a/ghc/docs/users_guide/prof-rts-options.lit +++ b/ghc/docs/users_guide/prof-rts-options.lit @@ -64,10 +64,10 @@ The heap space profile may be broken down by different criteria: \item[\tr{-hG}:] cost centre group which produced the closure. \item[\tr{-hD}:] closure description --- a string describing the closure. \item[\tr{-hY}:] closure type --- a string describing the closure's type. -\item[\tr{-hT<ints>,<start>}:] the time interval the closure was -created. \tr{<ints>} specifies the no. of interval bands plotted -(default 18) and \tr{<start>} the number of seconds after which the -reported intervals start (default 0.0). +%\item[\tr{-hT<ints>,<start>}:] the time interval the closure was +%created. \tr{<ints>} specifies the no. of interval bands plotted +%(default 18) and \tr{<start>} the number of seconds after which the +%reported intervals start (default 0.0). \end{description} By default all live closures in the heap are profiled, but particular closures of interest can be selected (see below). @@ -107,14 +107,14 @@ Selects closures which are of one of the specified closure kinds. Valid closure kinds are \tr{CON} (constructor), \tr{FN} (manifest function), \tr{PAP} (partial application), \tr{BH} (black hole) and \tr{THK} (thunk). -\item[\tr{-a<age>}:] -\index{-a<age> RTS option (profiling)} -Selects closures which have survived \pl{<age>} complete intervals. +%\item[\tr{-a<age>}:] +%\index{-a<age> RTS option (profiling)} +%Selects closures which have survived \pl{<age>} complete intervals. \end{description} The space occupied by a closure will be reported in the heap profile if the closure satisfies the following logical expression: \begin{display} -([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) and [-a] +([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) %and [-a] \end{display} where a particular option is true if the closure (or its attached cost centre) is selected by the option (or the option is not specified). diff --git a/ghc/docs/users_guide/profiling.lit b/ghc/docs/users_guide/profiling.lit index 68d4a7e303..9f55739411 100644 --- a/ghc/docs/users_guide/profiling.lit +++ b/ghc/docs/users_guide/profiling.lit @@ -8,7 +8,7 @@ University of Glasgow\\ Glasgow, Scotland\\ G12 8QQ\\ \\ -Email: glasgow-haskell-\{bugs,request\}\@dcs.glasgow.ac.uk} +Email: glasgow-haskell-\{users,bugs\}-request\@dcs.glasgow.ac.uk} \maketitle \begin{rawlatex} \tableofcontents diff --git a/ghc/docs/users_guide/user.lit b/ghc/docs/users_guide/user.lit index 51f63e20a5..858a12b814 100644 --- a/ghc/docs/users_guide/user.lit +++ b/ghc/docs/users_guide/user.lit @@ -8,7 +8,7 @@ University of Glasgow\\ Glasgow, Scotland\\ G12 8QQ\\ \\ -Email: glasgow-haskell-\{bugs,request\}\@dcs.glasgow.ac.uk} +Email: glasgow-haskell-\{bugs,users\}-request\@dcs.glasgow.ac.uk} \maketitle \begin{rawlatex} \tableofcontents diff --git a/ghc/docs/users_guide/utils.lit b/ghc/docs/users_guide/utils.lit index d007621521..6ec326e6f9 100644 --- a/ghc/docs/users_guide/utils.lit +++ b/ghc/docs/users_guide/utils.lit @@ -27,7 +27,9 @@ HCFLAGS = -fhaskell-1.3 -cpp -hi-diffs $(EXTRA_HC_OPTS) SRCS = Main.lhs Foo.lhs Bar.lhs OBJS = Main.o Foo.o Bar.o -.SUFFIXES : .o .lhs +.SUFFIXES : .o .hi .lhs +.o.hi: + @: .lhs.o: $(RM) $@ $(HC) -c $< $(HCFLAGS) @@ -37,6 +39,14 @@ cool_pgm : $(OBJS) $(HC) -o $@ $(HCFLAGS) $(OBJS) \end{verbatim} +Note the cheesy \tr{.o.hi} rule: It records the dependency of the +interface (\tr{.hi}) file on the source. The rule says a \tr{.hi} +file can be made from a \tr{.o} file by doing... nothing. Which is +true. + +(Sophisticated \tr{make} variants may achieve some of the above more +elegantly. What we've shown should work with any \tr{make}.) + The only thing lacking in the above \tr{Makefile} is interface-file dependencies. If \tr{Foo.lhs} imports module \tr{Bar} and the \tr{Bar} interface changes, then \tr{Foo.lhs} needs to be recompiled. @@ -64,6 +74,9 @@ effect. However, a \tr{make} run that does nothing {\em does} mean mutually-recursive modules but, again, it may take multiple iterations to ``settle.'' +To see \tr{mkdependHS}'s command-line flags, give it a duff flag, +e.g., \tr{mkdependHS -help}. + %************************************************************************ %* * \subsection[hstags]{Emacs `TAGS' for Haskell: \tr{hstags}} diff --git a/ghc/docs/users_guide/vs_haskell.lit b/ghc/docs/users_guide/vs_haskell.lit index c4fc5e5b7b..912e2df78c 100644 --- a/ghc/docs/users_guide/vs_haskell.lit +++ b/ghc/docs/users_guide/vs_haskell.lit @@ -362,13 +362,13 @@ Here is our ``crib sheet'' for converting 1.2 I/O to 1.3. In most cases, it's really easy. \begin{enumerate} \item -Change \tr{readChan stdin} to \tr{hGetContents stdin}. +Change \tr{readChan stdin} to \tr{getContents}. \item Change \tr{appendChan stdout} to \tr{putStr}, which is equivalent to \tr{hPutStr stdout}. Change \tr{appendChan stderr} to \tr{hPutStr stderr}. \item -You need to \tr{import LibSystem} if you used @getArgs@, @getEnv@, +You need to \tr{import System} if you used @getArgs@, @getEnv@, or @getProgName@. \item Assuming continuation-style @Dialogue@ code, change \tr{... exit done $} @@ -378,6 +378,36 @@ If you had any functions named \tr{(>>)}, \tr{(>>=)}, or \tr{return}, change them to something else. \end{enumerate} +Also: +1.3 I/O all the way. +\tr{Dialogue} usually turns into \tr{IO ()}. +Use of \tr{StatusFile} request: rewrite (no equivalent exists). +Add \tr{import Ratio} if you use \tr{Rationals} at all. +Ditto: \tr{import Complex} if you use complex numbers. +Ditto: \tr{import Array} if you use arrays. Also: note that +Arrays now use ordinary pairs, rather than a separate \tr{Assoc} type. +May be easier to do: +infix 1 =: +(=:) a b = (a,b) +and switch := to =: +This can happen: \tr{LiteralInt.leStringToInt}; add spaces. +For \tr{minInt}/\tr{maxInt}, \tr{minChar}/\tr{maxChar} (???) +use the \tr{Bounded} class methods, \tr{minBound} and \tr{maxBound}. +Replace class \tr{Text} with \tr{Show}; on rare occasions, +you may need to do something for \tr{Read}, too. +The functions \tr{ord} and \tr{chr} have been replaced by +the class methods \tr{fromEnum} and \tr{toEnum}, respectively. +The changes, however, can lead to ambiguous overloading. +Need \tr{import IO} for anything interesting. +What was called \tr{handle} is now called \tr{catch}. +New keyword: \tr{do}. +Other clashes: e.g., \tr{seq}, \tr{fail}. +\tr{readDec} no longer exists; use ???. +Type of \tr{fail} changed? +\tr{(a `op` b) c = ...} is bogus. +`failWith x' now `fail x' +`fail x' now `fail (userError x)' + %************************************************************************ %* * \subsection[nonio-1-3]{Non-I/O things from the 1.3-DRAFT proposal} @@ -444,10 +474,10 @@ The error type is called \tr{IOError13}, rather than \tr{IOError} so...) You probably shouldn't be messing with \tr{IOError} much, anyway. -Some of the 1.3 I/O code, notably the Extremely Cool \tr{LibPosix} +Some of the 1.3 I/O code, notably the Extremely Cool \tr{Posix} stuff, is relatively untested. Go for it, but be wary... -\index{LibPosix bugs} -\index{bugs, LibPosix} +\index{Posix library bugs} +\index{bugs, Posix library} %************************************************************************ %* * @@ -470,7 +500,7 @@ required) and put into \tr{Lib*} interfaces (import required). GHC~0.26 still provides the I/O functions via \tr{Prelude.hi} (no import required). Ignore the ``June draft'' pleadings for -\tr{import LibIO}, and you'll be fine. +\tr{import IO}, and you'll be fine. {\em There is no guarantee that the final 1.3 proposal will look anything like the current DRAFT.} It ain't a standard until the fat @@ -557,11 +587,11 @@ with \tr{-fhaskell-1.3}...) To subvert the above process, you need only provide a @mainPrimIO :: PrimIO ()@ of your own -(in a module named \tr{Main}). Do {\em not} use a \tr{-fhaskell-1.3} flag! +(in a module named \tr{GHCmain}). Do {\em not} use a \tr{-fhaskell-1.3} flag! Here's a little example, stolen from Alastair Reid: \begin{verbatim} -module Main ( mainPrimIO ) where +module GHCmain ( mainPrimIO ) where import PreludeGlaST diff --git a/ghc/driver/Jmakefile b/ghc/driver/Jmakefile index 97e91005c0..507055379a 100644 --- a/ghc/driver/Jmakefile +++ b/ghc/driver/Jmakefile @@ -1,29 +1,19 @@ /* stuff to have before we get going */ MsubNeededHere(ghc) -#if BuildDataParallelHaskell == YES -MsubNeededHere(dphc) -#endif -LitStuffNeededHere(depend) +UnlitNeededHere(depend) InfoStuffNeededHere(docs) DYN_LOADABLE_BITS = \ - ghc-asm-sparc.prl \ - ghc-asm-solaris.prl \ - ghc-asm-m68k.prl \ ghc-asm.prl \ - ghc-asm-alpha.prl \ - ghc-asm-hppa.prl \ - ghc-asm-mips.prl \ + ghc-recomp.prl \ + ghc-iface.prl \ ghc-consist.prl \ ghc-split.prl /* Literate-pgmming suffix rules used herein */ -LitSuffixRule(.lprl,.prl) +UnlitSuffixRule(.lprl,.prl) MsubMakefileDependentProgramScriptTarget(PerlCmd,ghc,ghc.prl,/*no flags*/,/*Makefile*/) -#if BuildDataParallelHaskell == YES -MsubMakefileDependentProgramScriptTarget(PerlCmd,dphc,dphc.prl,,/*Makefile*/) -#endif AllTarget( $(DYN_LOADABLE_BITS) ) /* installation is hackish: because we may want to install w/ a diff name */ @@ -36,13 +26,6 @@ install:: $(MV) $(INSTBINDIR_GHC)/ghc-v-temp-name $(INSTBINDIR_GHC)/$(GHC_DRIVER_INST_NAME) $(RM) $(INSTBINDIR_GHC)/ghc-v-temp-name -#if BuildDataParallelHaskell == YES -InstallMsubbedScriptTarget(PerlCmd,dphc-v-temp-name,dphc.prl,$(INSTBINDIR_GHC)) -install:: - $(MV) $(INSTBINDIR_GHC)/dphc-v-temp-name $(INSTBINDIR_GHC)/dphc - $(RM) $(INSTBINDIR_GHC)/dphc-v-temp-name -#endif /* DPH */ - dyn_loadable_bits : $(DYN_LOADABLE_BITS) InstallMultNonExecTargets(dyn_loadable_bits, $(DYN_LOADABLE_BITS), $(INSTLIBDIR_GHC)) @@ -60,5 +43,3 @@ ClearTagsFile() DYN_LOADABLE_LPRLS = $(DYN_LOADABLE_BITS:.prl=.lprl) PerlTagsTarget( ghc.lprl $(DYN_LOADABLE_LPRLS) ) - -LitDocRootTargetWithNamedOutput(driver,lit,driver-standalone) diff --git a/ghc/driver/driver.lit b/ghc/driver/driver.lit deleted file mode 100644 index ca4a876143..0000000000 --- a/ghc/driver/driver.lit +++ /dev/null @@ -1,33 +0,0 @@ -\begin{onlystandalone} -\documentstyle[11pt,literate,a4wide]{article} -\begin{document} -\title{Driver: @ghc@} -\author{The GRASP team} -\date{January 1993} -\maketitle -\begin{rawlatex} -\tableofcontents -\end{rawlatex} -\end{onlystandalone} - -\begin{onlypartofdoc} -\section[Driver-for-compilation-system]{@ghc@: Driver for the compilation system} -\downsection -\end{onlypartofdoc} - -\input{ghc.lprl} - -\section[Driver-support]{Support code for the @ghc@ driver} -\downsection -\input{ghc-asm.lprl} -\input{ghc-consist.lprl} -\input{ghc-split.lprl} -\upsection - -\begin{onlypartofdoc} -\upsection -\end{onlypartofdoc} -\begin{onlystandalone} -\printindex -\end{document} -\end{onlystandalone} diff --git a/ghc/driver/ghc-asm-alpha.lprl b/ghc/driver/ghc-asm-alpha.lprl deleted file mode 100644 index 23ee45a16f..0000000000 --- a/ghc/driver/ghc-asm-alpha.lprl +++ /dev/null @@ -1,521 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files (alpha)} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -Any other required tidying up. -\end{itemize} - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %slowchk = (); # ditto, its regular "slow" entry code - %fastchk = (); # ditto, fast entry code - %closurechk = (); # ditto, the (static) closure - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - %directchk = (); # ditto, direct return code - - $i = 0; - $chkcat[0] = 'misc'; - - while (<INASM>) { -#??? next if /^\.stab.*___stg_split_marker/; -#??? next if /^\.stab.*ghc.*c_ID/; - - next if /^\s*$/; - - if ( /^\s+/ ) { # most common case first -- a simple line! - # duplicated from the bottom - $chk[$i] .= $_; - - } elsif ( /\.\.ng:$/ ) { # Local labels not to be confused with new chunks - $chk[$i] .= $_; - - } elsif ( /^\$C(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'string'; - $chksymb[$i] = $1; - - } elsif ( /^__stg_split_marker(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^([A-Za-z0-9_]+)_info:$/ ) { - $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; - $chksymb[$i] = $1; - - $slowchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_fast\d+:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; - $chksymb[$i] = $1; - - $fastchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_closure:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^ghc.*c_ID:/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'consist'; - - } elsif ( /^(__gnu_compiled_c|gcc2_compiled\.):/ ) { - ; # toss it - - } elsif ( /^ErrorIO_call_count:/ # HACK!!!! - || /^[A-Za-z0-9_]+\.\d+:$/ - || /^.*_CAT:/ # PROF: _entryname_CAT - || /^CC_.*_struct:/ # PROF: _CC_ccident_struct - || /^.*_done:/ # PROF: _module_done - || /^_module_registered:/ # PROF: _module_registered - ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^(ret_|djn_)/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; - $chksymb[$i] = $1; - - $directchk{$1} = $i; - - } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^[A-Za-z0-9_]/ ) { - local($thing); - chop($thing = $_); - print STDERR "Funny global thing?: $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^_(PRIn|PRStart).*:/ # pointer reversal GC routines - || /^CC_.*:/ # PROF: _CC_ccident - || /^_reg.*:/; # PROF: _reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } else { # simple line (duplicated at the top) - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - -# print STDERR "\nCLOSURES:\n"; -# foreach $s (sort (keys %closurechk)) { -# print STDERR "$s:\t\t",$closurechk{$s},"\n"; -# } -# print STDERR "\nINFOS:\n"; -# foreach $s (sort (keys %infochk)) { -# print STDERR "$s:\t\t",$infochk{$s},"\n"; -# } -# print STDERR "SLOWS:\n"; -# foreach $s (sort (keys %slowchk)) { -# print STDERR "$s:\t\t",$slowchk{$s},"\n"; -# } -# print STDERR "\nFASTS:\n"; -# foreach $s (sort (keys %fastchk)) { -# print STDERR "$s:\t\t",$fastchk{$s},"\n"; -# } - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - # NB: we start meddling at chunk 1, not chunk 0 - - # the first ".rdata" is quite magical; as of GCC 2.7.x, it - # spits a ".quad 0" in after the v first ".rdata"; we - # detect this special case (tossing the ".quad 0")! - $magic_rdata_seen = 0; - - for ($i = 1; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE):\n", $c; - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - if ( ! $magic_rdata_seen && $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/ ) { - $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/; - $magic_rdata_seen = 1; - } - - # pick some end-things and move them to the next chunk - - while ( $c =~ /^(\s*\.align\s+\d+\n)FUNNY#END#THING/ - || $c =~ /^(\s*\.(globl|ent)\s+\S+\n)FUNNY#END#THING/ - || $c =~ /^(\s*\#.*\n)FUNNY#END#THING/ - || $c =~ /^(\s*\.(file|loc)\s+\S+\s+\S+\n)FUNNY#END#THING/ - || $c =~ /^(\s*\.text\n|\s*\.r?data\n)FUNNY#END#THING/ ) { - $to_move = $1; - - if ( $to_move =~ /^\s*(\#|\.(file|globl|ent|loc))/ && $i < ($numchks - 1) ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/; - } - - if ($c =~ /^\t\.ent\s+(\S+)/) { - $ent = $1; - # toss all prologue stuff, except for loading gp, and the ..ng address - if (($p, $r) = split(/^\t\.prologue/, $c)) { -# print STDERR "$ent: prologue:\n$p\nrest:\n$r\n"; - if (($keep, $junk) = split(/\.\.ng:/, $p)) { - $c = $keep . "..ng:\n"; - } else { - print STDERR "malformed code block ($ent)?\n" - } - } - $c .= "\t.frame \$30,0,\$26,0\n\t.prologue" . $r; - } - - $c =~ s/FUNNY#END#THING//; - $chk[$i] = $c; # update w/ convenience copy - -# print STDERR "\nCHK $i (AFTER):\n", $c; - } - - # print out the header stuff first - - $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/\1"$ifile_root.hc"/; - print OUTASM $chk[0]; - - # print out all the literal strings second - for ($i = 1; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'string' ) { - print OUTASM "\.rdata\n\t\.align 3\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - for ($i = 1; $i < $numchks; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' ) { - print OUTASM "\.text\n\t\.align 3\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM "\.data\n\t\.align 3\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'consist' ) { - if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) { - local($consist) = "$1.$2.$3"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - print OUTASM "\.text\n$consist:\n"; - } else { - print STDERR "Couldn't grok consistency: ", $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - # ignore the final split marker, to save an empty object module - # Use _three_ underscores so that ghc-split doesn't get overly complicated - print OUTASM "___stg_split_marker",$chksymb[$i],":\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'slow' - || $chkcat[$i] eq 'fast' ) { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM "\.data\n\t\.align 3\n"; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM "\.text\n\t\.align 3\n"; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - # entry code will be put here! - - # paranoia - if ( $chk[$infochk{$symb}] =~ /\.quad\s+([A-Za-z0-9_]+_entry)$/ - && $1 ne "${symb}_entry" ) { - print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; - } - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # STD ENTRY POINT - if ( defined($slowchk{$symb}) ) { - - # teach it to drop through to the fast entry point: - $c = $chk[$slowchk{$symb}]; - if ( defined($fastchk{$symb}) ) { - $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/; - } - - # NB: no very good way to look for "dangling" references - # to fast-entry pt - - print OUTASM "\.text\n\t\.align 3\n"; - print OUTASM $c; - $chkcat[$slowchk{$symb}] = 'DONE ALREADY'; - } - - # FAST ENTRY POINT - if ( defined($fastchk{$symb}) ) { - $c = $chk[$fastchk{$symb}]; - if ( ! defined($slowchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 3\n"; - } - print OUTASM $c; - $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' - || $chkcat[$i] eq 'direct' ) { # do them in that order - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 3\n"; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - } - - # DIRECT RETURN - if ( defined($directchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 3\n"; - print OUTASM $chk[$directchk{$symb}]; - $chkcat[$directchk{$symb}] = 'DONE ALREADY'; - } else { - # The commented nop is for the splitter, to ensure - # that no module ends with a label as the very last - # thing. (The linker will adjust the label to point - # to the first code word of the next module linked in, - # even if alignment constraints cause the label to move!) - - print OUTASM "\t# nop\n"; - } - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm alpha)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - %KNOWN_FUNNY_THING = ( - 'CheckHeapCode:', 1, - 'CommonUnderflow:', 1, - 'Continue:', 1, - 'EnterNodeCode:', 1, - 'ErrorIO_call_count:', 1, - 'ErrorIO_innards:', 1, - 'IndUpdRetDir:', 1, - 'IndUpdRetV0:', 1, - 'IndUpdRetV1:', 1, - 'IndUpdRetV2:', 1, - 'IndUpdRetV3:', 1, - 'IndUpdRetV4:', 1, - 'IndUpdRetV5:', 1, - 'IndUpdRetV6:', 1, - 'IndUpdRetV7:', 1, - 'PrimUnderflow:', 1, - 'StackUnderflowEnterNode:', 1, - 'StdErrorCode:', 1, - 'UnderflowVect0:', 1, - 'UnderflowVect1:', 1, - 'UnderflowVect2:', 1, - 'UnderflowVect3:', 1, - 'UnderflowVect4:', 1, - 'UnderflowVect5:', 1, - 'UnderflowVect6:', 1, - 'UnderflowVect7:', 1, - 'UpdErr:', 1, - 'UpdatePAP:', 1, - 'WorldStateToken:', 1, - '_Enter_Internal:', 1, - '_PRMarking_MarkNextAStack:', 1, - '_PRMarking_MarkNextBStack:', 1, - '_PRMarking_MarkNextCAF:', 1, - '_PRMarking_MarkNextGA:', 1, - '_PRMarking_MarkNextRoot:', 1, - '_PRMarking_MarkNextSpark:', 1, - '_Scavenge_Forward_Ref:', 1, - '__std_entry_error__:', 1, - '_startMarkWorld:', 1, - 'resumeThread:', 1, - 'startCcRegisteringWorld:', 1, - 'startEnterFloat:', 1, - 'startEnterInt:', 1, - 'startPerformIO:', 1, - 'startStgWorld:', 1, - 'stopPerformIO:', 1 - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.quad\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/ - || $lines[$i] =~ /^\t\.globl/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.quad\s+/; $i++) { - push(@words, $lines[$i]); - } - # now throw away the first word (entry code): - shift(@words) if $discard1; - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - # If we have anonymous text (not part of a procedure), the linker - # may complain about missing exception information. Bleh. - if ($label =~ /^([A-Za-z0-9_]+):$/) { - $before = "\t.ent $1\n" . $before; - $after .= "\t.end $1\n"; - } - - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -%************************************************************************ -%* * -\subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file} -%* * -%************************************************************************ - -How many times is each asm instruction used? - -\begin{code} -%AsmInsn = (); # init - -sub dump_asm_insn_counts { - local($asmf) = @_; - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\t([a-z][a-z0-9]+)\b/ ) { - $AsmInsn{$1} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %AsmInsn)) { - print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n"; - } -} - -sub dump_asm_globals_info { -} - -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc-asm-hppa.lprl b/ghc/driver/ghc-asm-hppa.lprl deleted file mode 100644 index 1032a369ec..0000000000 --- a/ghc/driver/ghc-asm-hppa.lprl +++ /dev/null @@ -1,582 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files (HP-PA)} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -Any other required tidying up. -\end{itemize} - -HP specific notes: -\begin{itemize} -\item -The HP linker is very picky about symbols being in the appropriate -space (code vs. data). When we mangle the threaded code to put the -info tables just prior to the code, they wind up in code space -rather than data space. This means that references to *_info from -un-mangled parts of the RTS (e.g. unthreaded GC code) get -unresolved symbols. Solution: mini-mangler for .c files on HP. I -think this should really be triggered in the driver by a new -rts -option, so that user code doesn't get mangled inappropriately. -\item -With reversed tables, jumps are to the _info label rather than to -the _entry label. The _info label is just an address in code -space, rather than an entry point with the descriptive blob we -talked about yesterday. As a result, you can't use the call-style -JMP_ macro. However, some JMP_ macros take _info labels as targets -and some take code entry points within the RTS. The latter won't -work with the goto-style JMP_ macro. Sigh. Solution: Use the goto -style JMP_ macro, and mangle some more assembly, changing all -"RP'literal" and "LP'literal" references to "R'literal" and -"L'literal," so that you get the real address of the code, rather -than the descriptive blob. Also change all ".word P%literal" -entries in info tables and vector tables to just ".word literal," -for the same reason. Advantage: No more ridiculous call sequences. -\end{itemize} - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %slowchk = (); # ditto, its regular "slow" entry code - %fastchk = (); # ditto, fast entry code - %closurechk = (); # ditto, the (static) closure - %infochk = (); # ditto, normal info tbl - %vectorchk = (); # ditto, return vector table - %directchk = (); # ditto, direct return code - - $i = 0; - $chkcat[0] = 'misc'; - - while (<INASM>) { -#??? next if /^\.stab.*___stg_split_marker/; -#??? next if /^\.stab.*ghc.*c_ID/; - - next if /^;/; - - if ( /^\s+/ ) { # most common case first -- a simple line! - # duplicated from the bottom - $chk[$i] .= $_; - - } elsif ( /^L\$C(\d+)$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'literal'; - $chksymb[$i] = $1; - - } elsif ( /^__stg_split_marker(\d+)$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^([A-Za-z0-9_]+)_info$/ ) { - $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_entry$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; - $chksymb[$i] = $1; - - $slowchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_fast\d+$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; - $chksymb[$i] = $1; - - $fastchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_closure$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^ghc.*c_ID/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'consist'; - - } elsif ( /^(__gnu_compiled_c|gcc2_compiled\.)/ ) { - ; # toss it - - } elsif ( /^ErrorIO_call_count/ # HACK!!!! - || /^[A-Za-z0-9_]+\.\d+$/ - || /^.*_CAT/ # PROF: _entryname_CAT - || /^CC_.*_struct/ # PROF: _CC_ccident_struct - || /^.*_done/ # PROF: _module_done - || /^_module_registered/ # PROF: _module_registered - ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^([A-Za-z0-9_]+)\s+\.comm/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'bss'; - $chksymb[$i] = $1; - - } elsif ( /^(ret_|djn_)/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^vtbl_([A-Za-z0-9_]+)$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)DirectReturn$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; - $chksymb[$i] = $1; - - $directchk{$1} = $i; - - } elsif ( /^[A-Za-z0-9_]+_upd$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^[A-Za-z0-9_]/ && ! /^L\$\d+$/) { - local($thing); - chop($thing = $_); - print STDERR "Funny global thing?: $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^_(PRIn|PRStart)/ # pointer reversal GC routines - || /^CC_.*/ # PROF: _CC_ccident - || /^_reg.*/; # PROF: _reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } else { # simple line (duplicated at the top) - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - -# print STDERR "\nCLOSURES:\n"; -# foreach $s (sort (keys %closurechk)) { -# print STDERR "$s:\t\t",$closurechk{$s},"\n"; -# } -# print STDERR "\nNORMAL INFOS:\n"; -# foreach $s (sort (keys %infochk)) { -# print STDERR "$s:\t\t",$infochk{$s},"\n"; -# } -# print STDERR "SLOWS:\n"; -# foreach $s (sort (keys %slowchk)) { -# print STDERR "$s:\t\t",$slowchk{$s},"\n"; -# } -# print STDERR "\nFASTS:\n"; -# foreach $s (sort (keys %fastchk)) { -# print STDERR "$s:\t\t",$fastchk{$s},"\n"; -# } - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - # NB: we start meddling at chunk 1, not chunk 0 - - for ($i = 1; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE):\n", $c; - - # toss all prologue stuff - $c =~ s/^\s+\.ENTRY[^\0]*--- BEGIN ---/\t.ENTRY/; - - # Lie about our .CALLINFO - $c =~ s/^\s+\.CALLINFO.*$/\t.CALLINFO NO_CALLS,NO_UNWIND/; - - # Get rid of P' - - $c =~ s/LP'/L'/g; - $c =~ s/RP'/R'/g; - -# print STDERR "\nCHK $i (STEP 1):\n", $c; - - # toss all epilogue stuff - $c =~ s/^\s+--- END ---[^\0]*\.EXIT/\t.EXIT/; - -# print STDERR "\nCHK $i (STEP 2):\n", $c; - - # Sorry; we moved the _info stuff to the code segment. - $c =~ s/_info,DATA/_info,CODE/g; - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - # pick some end-things and move them to the next chunk - -# print STDERR "\nCHK $i (STEP 3):\n", $c; - while ($c =~ /^(\s+\.(IMPORT|EXPORT|PARAM).*\n)FUNNY#END#THING/ - || $c =~ /^(\s+\.align\s+\d+\n)FUNNY#END#THING/ - || $c =~ /^(\s+\.(SPACE|SUBSPA)\s+\S+\n)FUNNY#END#THING/ - || $c =~ /^(\s*\n)FUNNY#END#THING/ ) { - $to_move = $1; - - if ( $i < ($numchks - 1) && ($to_move =~ /^\s+\.(IMPORT|EXPORT)/ - || ($to_move =~ /align/ && $chkcat[$i+1] eq 'literal')) ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/; - } -# print STDERR "\nCHK $i (STEP 4):\n", $c; - - $c =~ s/FUNNY#END#THING//; - $chk[$i] = $c; # update w/ convenience copy - } - - # print out the header stuff first - - print OUTASM $chk[0]; - - # print out all the literals second - - for ($i = 1; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'literal' ) { - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n"; - print OUTASM $chk[$i]; - print OUTASM "; end literal\n"; # for the splitter - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - # print out all the bss third - - for ($i = 1; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'bss' ) { - print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$BSS\$\n\t.align 4\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - for ($i = 1; $i < $numchks; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' ) { - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'consist' ) { - if ( $chk[$i] =~ /\.STRING.*\)(hsc|cc) (.*)\\x09(.*)\\x00/ ) { - local($consist) = "$1.$2.$3"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n$consist\n"; - } else { - print STDERR "Couldn't grok consistency: ", $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - # ignore the final split marker, to save an empty object module - # Use _three_ underscores so that ghc-split doesn't get overly complicated - print OUTASM "___stg_split_marker$chksymb[$i]\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'slow' - || $chkcat[$i] eq 'fast' ) { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - # entry code will be put here! - - # paranoia - if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/ - && $1 ne "${symb}_entry" ) { - print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; - } - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # STD ENTRY POINT - if ( defined($slowchk{$symb}) ) { - - # teach it to drop through to the fast entry point: - $c = $chk[$slowchk{$symb}]; - if ( defined($fastchk{$symb}) ) { - $c =~ s/^\s+ldil.*\n\s+ldo.*\n\s+bv.*\n(.*\n)?\s+\.EXIT/$1\t.EXIT/; - } - - # ToDo: ???? any good way to look for "dangling" references - # to fast-entry pt ??? - - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - print OUTASM $c; - $chkcat[$slowchk{$symb}] = 'DONE ALREADY'; - } - - # FAST ENTRY POINT - if ( defined($fastchk{$symb}) ) { - $c = $chk[$fastchk{$symb}]; - if ( ! defined($slowchk{$symb}) ) { - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - } - print OUTASM $c; - $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' - || $chkcat[$i] eq 'direct' ) { # do them in that order - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - } - - # DIRECT RETURN - if ( defined($directchk{$symb}) ) { - print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - print OUTASM $chk[$directchk{$symb}]; - $chkcat[$directchk{$symb}] = 'DONE ALREADY'; - } - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm hppa)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -The HP is a major nuisance. The threaded code mangler moved info tables -from data space to code space, but unthreaded code in the RTS still has -references to info tables in data space. Since the HP linker is very precise -about where symbols live, we need to patch the references in the unthreaded -RTS as well. - -\begin{code} - -sub mini_mangle_asm { - local($in_asmf, $out_asmf) = @_; - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - while (<INASM>) { - s/_info,DATA/_info,CODE/; # Move _info references to code space - s/P%_PR/_PR/; - print OUTASM; - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} - -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - %KNOWN_FUNNY_THING = ( - 'CheckHeapCode', 1, - 'CommonUnderflow', 1, - 'Continue', 1, - 'EnterNodeCode', 1, - 'ErrorIO_call_count', 1, - 'ErrorIO_innards', 1, - 'IndUpdRetDir', 1, - 'IndUpdRetV0', 1, - 'IndUpdRetV1', 1, - 'IndUpdRetV2', 1, - 'IndUpdRetV3', 1, - 'IndUpdRetV4', 1, - 'IndUpdRetV5', 1, - 'IndUpdRetV6', 1, - 'IndUpdRetV7', 1, - 'PrimUnderflow', 1, - 'StackUnderflowEnterNode', 1, - 'StdErrorCode', 1, - 'UnderflowVect0', 1, - 'UnderflowVect1', 1, - 'UnderflowVect2', 1, - 'UnderflowVect3', 1, - 'UnderflowVect4', 1, - 'UnderflowVect5', 1, - 'UnderflowVect6', 1, - 'UnderflowVect7', 1, - 'UpdErr', 1, - 'UpdatePAP', 1, - 'WorldStateToken', 1, - '_Enter_Internal', 1, - '_PRMarking_MarkNextAStack', 1, - '_PRMarking_MarkNextBStack', 1, - '_PRMarking_MarkNextCAF', 1, - '_PRMarking_MarkNextGA', 1, - '_PRMarking_MarkNextRoot', 1, - '_PRMarking_MarkNextSpark', 1, - '_Scavenge_Forward_Ref', 1, - '__std_entry_error__', 1, - '_startMarkWorld', 1, - 'resumeThread', 1, - 'startCcRegisteringWorld', 1, - 'startEnterFloat', 1, - 'startEnterInt', 1, - 'startPerformIO', 1, - 'startStgWorld', 1, - 'stopPerformIO', 1 - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@imports) = (); - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\s+\.word\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+$/ - || $lines[$i] =~ /^\s+\.EXPORT/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\s+\.(word|IMPORT)/; $i++) { - if ($lines[$i] =~ /^\s+\.IMPORT/) { - push(@imports, $lines[$i]); - } else { - # We don't use HP's ``function pointers'' - # We just use labels in code space, like normal people - $lines[$i] =~ s/P%//; - push(@words, $lines[$i]); - } - } - # now throw away the first word (entry code): - if ($discard1) { - shift(@words); - } - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - $tbl = $before . join("\n", @imports) . "\n" . - join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -%************************************************************************ -%* * -\subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file} -%* * -%************************************************************************ - -How many times is each asm instruction used? - -\begin{code} -%AsmInsn = (); # init - -sub dump_asm_insn_counts { - local($asmf) = @_; - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\t([a-z][a-z0-9]+)\b/ ) { - $AsmInsn{$1} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %AsmInsn)) { - print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n"; - } -} - -sub dump_asm_globals_info { -} - -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc-asm-m68k.lprl b/ghc/driver/ghc-asm-m68k.lprl deleted file mode 100644 index e3a1431e60..0000000000 --- a/ghc/driver/ghc-asm-m68k.lprl +++ /dev/null @@ -1,486 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files (m68k)} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -Any other required tidying up. -\end{itemize} - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %slowchk = (); # ditto, its regular "slow" entry code - %fastchk = (); # ditto, fast entry code - %closurechk = (); # ditto, the (static) closure - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - %directchk = (); # ditto, direct return code - - $i = 0; - $chkcat[0] = 'misc'; - - while (<INASM>) { - next if /^\.stab.*___stg_split_marker/; - next if /^\.stab.*ghc.*c_ID/; - next if /^#(NO_)?APP/; - - if ( /^\s+/ ) { # most common case first -- a simple line! - # duplicated from the bottom - - $chk[$i] .= $_; - - } elsif ( /^LC(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'string'; - $chksymb[$i] = $1; - - } elsif ( /^___stg_split_marker(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^_([A-Za-z0-9_]+)_info:$/ ) { - $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)_entry:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; - $chksymb[$i] = $1; - - $slowchk{$1} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)_fast\d+:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; - $chksymb[$i] = $1; - - $fastchk{$1} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)_closure:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^_ghc.*c_ID:/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'consist'; - - } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.):/ ) { - ; # toss it - - } elsif ( /^_ErrorIO_call_count:/ # HACK!!!! - || /^_[A-Za-z0-9_]+\.\d+:$/ - || /^_.*_CAT:/ # PROF: _entryname_CAT - || /^_CC_.*_struct:/ # PROF: _CC_ccident_struct - || /^_.*_done:/ # PROF: _module_done - || /^__module_registered:/ # PROF: _module_registered - ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^_(ret_|djn_)/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; - $chksymb[$i] = $1; - - $directchk{$1} = $i; - - } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^_[A-Za-z0-9_]/ ) { - local($thing); - chop($thing = $_); - print STDERR "Funny global thing?: $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^__(PRIn|PRStart).*:/ # pointer reversal GC routines - || /^_CC_.*:/ # PROF: _CC_ccident - || /^__reg.*:/; # PROF: __reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } else { # simple line (duplicated at the top) - - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - # NB: we start meddling at chunk 1, not chunk 0 - - for ($i = 1; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c; - - # toss all prologue stuff; - # be slightly paranoid to make sure there's - # nothing surprising in there - if ( $c =~ /--- BEGIN ---/ ) { - if (($p, $r) = split(/--- BEGIN ---/, $c)) { - $p =~ s/^\tlink a6,#-?\d.*\n//; - $p =~ s/^\tmovel d2,sp\@-\n//; - $p =~ s/^\tmovel d5,sp\@-\n//; # SMmark.* only? - $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//; # SMmark.* only? - die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/; - - # glue together what's left - $c = $p . $r; - } - } - - # toss all epilogue stuff; again, paranoidly - if ( $c =~ /--- END ---/ ) { - if (($r, $e) = split(/--- END ---/, $c)) { - $e =~ s/^\tunlk a6\n//; - $e =~ s/^\trts\n//; - die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/; - - # glue together what's left - $c = $r . $e; - } - } - - # toss all calls to __DISCARD__ - $c =~ s/^\tjbsr ___DISCARD__\n//g; - - # toss stack adjustment after DoSparks - $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/g; - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - # pick some end-things and move them to the next chunk - - while ( $c =~ /^\s*(\.align\s+\d+\n|\.proc\s+\d+\n|\.const\n|\.cstring\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.even\n|\.stab[^n].*\n)FUNNY#END#THING/ ) { - $to_move = $1; - - if ( $to_move =~ /\.(globl|proc|stab)/ && $i < ($numchks - 1) ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/; - } - - $c =~ s/FUNNY#END#THING//; - $chk[$i] = $c; # update w/ convenience copy - } - - # print out all the literal strings first - for ($i = 0; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'string' ) { - print OUTASM "\.text\n\t\.even\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - for ($i = 0; $i < $numchks; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' ) { - print OUTASM "\.text\n\t\.even\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM "\.data\n\t\.even\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'consist' ) { - if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) { - local($consist) = "$1.$2.$3"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - print OUTASM "\.text\n$consist:\n"; - } else { - print STDERR "Couldn't grok consistency: ", $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - print OUTASM "___stg_split_marker",$chksymb[$i],":\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'slow' - || $chkcat[$i] eq 'fast' ) { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM "\.data\n\t\.even\n"; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM "\.text\n\t\.even\n"; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - # entry code will be put here! - - # paranoia - if ( $chk[$infochk{$symb}] =~ /\.long\s+([A-Za-z0-9_]+_entry)$/ - && $1 ne "_${symb}_entry" ) { - print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; - } - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # STD ENTRY POINT - if ( defined($slowchk{$symb}) ) { - - # teach it to drop through to the fast entry point: - $c = $chk[$slowchk{$symb}]; - - if ( defined($fastchk{$symb}) ) { - $c =~ s/^\tjmp _${symb}_fast\d+.*\n\tnop\n//; - $c =~ s/^\tjmp _${symb}_fast\d+.*\n//; - } - - print STDERR "still has jump to fast entry point:\n$c" - if $c =~ /_${symb}_fast/; # NB: paranoia - - print OUTASM "\.text\n\t\.even\n"; - print OUTASM $c; - $chkcat[$slowchk{$symb}] = 'DONE ALREADY'; - } - - # FAST ENTRY POINT - if ( defined($fastchk{$symb}) ) { - print OUTASM "\.text\n\t\.even\n"; - print OUTASM $chk[$fastchk{$symb}]; - $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' - || $chkcat[$i] eq 'direct' ) { # do them in that order - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM "\.text\n\t\.even\n"; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - } - - # DIRECT RETURN - if ( defined($directchk{$symb}) ) { - print OUTASM "\.text\n\t\.even\n"; - print OUTASM $chk[$directchk{$symb}]; - $chkcat[$directchk{$symb}] = 'DONE ALREADY'; - } - - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm m68k)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - %KNOWN_FUNNY_THING = ( - '_CheckHeapCode:', 1, - '_CommonUnderflow:', 1, - '_Continue:', 1, - '_EnterNodeCode:', 1, - '_ErrorIO_call_count:', 1, - '_ErrorIO_innards:', 1, - '_IndUpdRetDir:', 1, - '_IndUpdRetV0:', 1, - '_IndUpdRetV1:', 1, - '_IndUpdRetV2:', 1, - '_IndUpdRetV3:', 1, - '_IndUpdRetV4:', 1, - '_IndUpdRetV5:', 1, - '_IndUpdRetV6:', 1, - '_IndUpdRetV7:', 1, - '_PrimUnderflow:', 1, - '_StackUnderflowEnterNode:', 1, - '_StdErrorCode:', 1, - '_UnderflowVect0:', 1, - '_UnderflowVect1:', 1, - '_UnderflowVect2:', 1, - '_UnderflowVect3:', 1, - '_UnderflowVect4:', 1, - '_UnderflowVect5:', 1, - '_UnderflowVect6:', 1, - '_UnderflowVect7:', 1, - '_UpdErr:', 1, - '_UpdatePAP:', 1, - '_WorldStateToken:', 1, - '__Enter_Internal:', 1, - '__PRMarking_MarkNextAStack:', 1, - '__PRMarking_MarkNextBStack:', 1, - '__PRMarking_MarkNextCAF:', 1, - '__PRMarking_MarkNextGA:', 1, - '__PRMarking_MarkNextRoot:', 1, - '__PRMarking_MarkNextSpark:', 1, - '__Scavenge_Forward_Ref:', 1, - '___std_entry_error__:', 1, - '__startMarkWorld:', 1, - '_resumeThread:', 1, - '_startCcRegisteringWorld:', 1, - '_startEnterFloat:', 1, - '_startEnterInt:', 1, - '_startPerformIO:', 1, - '_startStgWorld:', 1, - '_stopPerformIO:', 1 - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.long\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/ - || $lines[$i] =~ /^\.globl/ - || $lines[$i] =~ /^_vtbl_\S+:$/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\s+/; $i++) { - push(@words, $lines[$i]); - } - # now throw away the first word (entry code): - shift(@words) if $discard1; - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -%************************************************************************ -%* * -\subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file} -%* * -%************************************************************************ - -How many times is each asm instruction used? - -\begin{code} -%AsmInsn = (); # init - -sub dump_asm_insn_counts { - local($asmf) = @_; - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\t([a-z][a-z0-9]+)\b/ ) { - $AsmInsn{$1} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %AsmInsn)) { - print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n"; - } -} - -sub dump_asm_globals_info { -} - -# make "require"r happy... -1; - -\end{code} diff --git a/ghc/driver/ghc-asm-mips.lprl b/ghc/driver/ghc-asm-mips.lprl deleted file mode 100644 index 3c210cb973..0000000000 --- a/ghc/driver/ghc-asm-mips.lprl +++ /dev/null @@ -1,529 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files (SGI MIPS box)} -%* * -%************************************************************************ - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %slowchk = (); # ditto, its regular "slow" entry code - %fastchk = (); # ditto, fast entry code - %closurechk = (); # ditto, the (static) closure - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - %directchk = (); # ditto, direct return code - $EXTERN_DECLS = ''; # .globl <foo> .text - - $i = 0; - $chkcat[0] = 'misc'; - - while (<INASM>) { - - next if /^$/; # blank line - next if /^\s*#(NO_)?APP/; - next if /^\t\.file\t/; - next if /^ # /; - - if ( /^\t\.(globl \S+ \.text|comm\t)/ ) { - $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/; - - } elsif ( /^\s+/ ) { # most common case first -- a simple line! - # duplicated from the bottom - $chk[$i] .= $_; - - # NB: all the rest start with a non-space - - } elsif ( /^\d+:/ ) { # a funny-looking very-local label - $chk[$i] .= $_; - - } elsif ( /^\$LC(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'string'; - $chksymb[$i] = $1; - - } elsif ( /^__stg_split_marker(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^([A-Za-z0-9_]+)_info:$/ ) { - $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; - $chksymb[$i] = $1; - - $slowchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_fast\d+:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; - $chksymb[$i] = $1; - - $fastchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_closure:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^ghc.*c_ID:/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'consist'; - - } elsif ( /^(__gnu_compiled_c|gcc2_compiled\.):/ ) { - ; # toss it - - } elsif ( /^ErrorIO_call_count:/ # HACK!!!! - || /^[A-Za-z0-9_]+\.\d+:$/ - || /^.*_CAT:/ # PROF: _entryname_CAT - || /^CC_.*_struct:/ # PROF: _CC_ccident_struct - || /^.*_done:/ # PROF: _module_done - || /^_module_registered:/ # PROF: _module_registered - ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^(ret_|djn_)/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; - $chksymb[$i] = $1; - - $directchk{$1} = $i; - - } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^[A-Za-z0-9_]/ ) { - local($thing); - chop($thing = $_); - print STDERR "Funny global thing? ($.): $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^_(PRIn|PRStart).*:/ # pointer reversal GC routines - || /^CC_.*:/ # PROF: _CC_ccident - || /^_reg.*:/; # PROF: _reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } else { # simple line (duplicated at the top) - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - -# print STDERR "\nCLOSURES:\n"; -# foreach $s (sort (keys %closurechk)) { -# print STDERR "$s:\t\t",$closurechk{$s},"\n"; -# } -# print STDERR "\nINFOS:\n"; -# foreach $s (sort (keys %infochk)) { -# print STDERR "$s:\t\t",$infochk{$s},"\n"; -# } -# print STDERR "SLOWS:\n"; -# foreach $s (sort (keys %slowchk)) { -# print STDERR "$s:\t\t",$slowchk{$s},"\n"; -# } -# print STDERR "\nFASTS:\n"; -# foreach $s (sort (keys %fastchk)) { -# print STDERR "$s:\t\t",$fastchk{$s},"\n"; -# } - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - # NB: we start meddling at chunk 1, not chunk 0 - - for ($i = 1; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE):\n", $c; - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - # pick some end-things and move them to the next chunk - - while ( $c =~ /^(\s*\.align\s+\d+\n)FUNNY#END#THING/ - || $c =~ /^(\s*\.(globl|ent)\s+\S+\n)FUNNY#END#THING/ - || $c =~ /^(\s*\.text\n|\s*\.r?data\n)FUNNY#END#THING/ ) { - $to_move = $1; - - if ( $to_move =~ /\.(globl|ent)/ && $i < ($numchks - 1) ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/; - } - - # toss all prologue stuff; - # be slightly paranoid to make sure there's - # nothing surprising in there - if ( $c =~ /--- BEGIN ---/ ) { - if (($p, $r) = split(/--- BEGIN ---/, $c)) { - # the .frame/.mask/.fmask that we use is the same - # as that produced by GCC for miniInterpret; this - # gives GDB some chance of figuring out what happened - $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n"; - $p =~ s/^\t\.(frame).*\n/__FRAME__/g; - $p =~ s/^\t\.(mask|fmask).*\n//g; - $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/; # 16 + 100 4-byte args - $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//; - $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//; - $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//; - $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//; - $p =~ s/__FRAME__/$FRAME/; - die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/; - - # glue together what's left - $c = $p . $r; - $c =~ s/\n\t\n/\n/; # junk blank line - } - } - - # toss all epilogue stuff; again, paranoidly; - # first, this basic sequence may occur "--- END ---" or not - $c =~ s/^\tlw\t\$31,\d+\(\$sp\)\n\taddu\t\$sp,\$sp,\d+\n\tj\t\$31\n\t\.end/\t\.end/; - - if ( $c =~ /--- END ---/ ) { - if (($r, $e) = split(/--- END ---/, $c)) { - $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//; - $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//; - $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//; - $e =~ s/^\tj\t\$31\n//; - die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/; - - # glue together what's left - $c = $r . $e; - $c =~ s/\n\t\n/\n/; # junk blank line - } - } - - # toss all calls to __DISCARD__ - $c =~ s/^\tjal\t__DISCARD__\n//g; - # that may leave some gratuitous asm macros around - # (no harm done; but we get rid of them to be tidier) - $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/; - - $c =~ s/FUNNY#END#THING//; - $chk[$i] = $c; # update w/ convenience copy - - print STDERR "NB: Contains magic stuff!\n$c\n" if $c =~ /^\t[^\.].*(\$28)\b/; - -# print STDERR "\nCHK $i (AFTER):\n", $c; - - } - - # print out the header stuff first - $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0]; - - # get rid of horrible "<dollar>Revision: .*$" strings - local(@lines0) = split(/\n/, $chk[0]); - local($z) = 0; - while ( $z <= $#lines0 ) { - if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/ ) { - undef($lines0[$z]); - $z++; - while ( $z <= $#lines0 ) { - undef($lines0[$z]); - last if $lines0[$z] =~ /[,\t]0x0$/; - $z++; - } - } - $z++; - } - $chk[0] = join("\n", @lines0); - $chk[0] =~ s/\n\n+/\n/; - print OUTASM $chk[0]; - - # print out all the literal strings second - for ($i = 1; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'string' ) { - print OUTASM "\t\.rdata\n\t\.align 2\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - for ($i = 1; $i < $numchks; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' ) { - print OUTASM "\t\.text\n\t\.align 2\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM "\t\.data\n\t\.align 2\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'consist' ) { -#? consistency string is just a v -#? horrible bunch of .bytes, -#? which I am too lazy to sort out (WDP 95/05) -#? if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) { -#? local($consist) = "$1.$2.$3"; -#? $consist =~ s/,/./g; -#? $consist =~ s/\//./g; -#? $consist =~ s/-/_/g; -#? $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? -#? print OUTASM "\t\.text\n$consist:\n"; -#? } else { -#? print STDERR "Couldn't grok consistency: ", $chk[$i]; -#? } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - # ignore the final split marker, to save an empty object module - # Use _three_ underscores so that ghc-split doesn't get overly complicated - print OUTASM "___stg_split_marker",$chksymb[$i],":\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'slow' - || $chkcat[$i] eq 'fast' ) { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM "\t\.data\n\t\.align 2\n"; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM "\t\.text\n\t\.align 2\n"; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - # entry code will be put here! - - # paranoia - if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/ - && $1 ne "${symb}_entry" ) { - print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; - } - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # STD ENTRY POINT - if ( defined($slowchk{$symb}) ) { - - # teach it to drop through to the fast entry point: - $c = $chk[$slowchk{$symb}]; - - if ( defined($fastchk{$symb}) ) { - $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/; - } - - # ToDo??? any good way to look for "dangling" references - # to fast-entry pt ??? - - print OUTASM "\t\.text\n\t\.align 2\n"; - print OUTASM $c; - $chkcat[$slowchk{$symb}] = 'DONE ALREADY'; - } - - # FAST ENTRY POINT - if ( defined($fastchk{$symb}) ) { - $c = $chk[$fastchk{$symb}]; - if ( ! defined($slowchk{$symb}) ) { - print OUTASM "\t\.text\n\t\.align 2\n"; - } - print OUTASM $c; - $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' - || $chkcat[$i] eq 'direct' ) { # do them in that order - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM "\t\.text\n\t\.align 2\n"; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - } - - # DIRECT RETURN - if ( defined($directchk{$symb}) ) { - print OUTASM "\t\.text\n\t\.align 2\n"; - print OUTASM $chk[$directchk{$symb}]; - $chkcat[$directchk{$symb}] = 'DONE ALREADY'; - } else { - # The commented nop is for the splitter, to ensure - # that no module ends with a label as the very last - # thing. (The linker will adjust the label to point - # to the first code word of the next module linked in, - # even if alignment constraints cause the label to move!) - - print OUTASM "\t# nop\n"; - } - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm alpha)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - print OUTASM $EXTERN_DECLS; - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - %KNOWN_FUNNY_THING = ( - 'CheckHeapCode:', 1, - 'CommonUnderflow:', 1, - 'Continue:', 1, - 'EnterNodeCode:', 1, - 'ErrorIO_call_count:', 1, - 'ErrorIO_innards:', 1, - 'IndUpdRetDir:', 1, - 'IndUpdRetV0:', 1, - 'IndUpdRetV1:', 1, - 'IndUpdRetV2:', 1, - 'IndUpdRetV3:', 1, - 'IndUpdRetV4:', 1, - 'IndUpdRetV5:', 1, - 'IndUpdRetV6:', 1, - 'IndUpdRetV7:', 1, - 'PrimUnderflow:', 1, - 'StackUnderflowEnterNode:', 1, - 'StdErrorCode:', 1, - 'UnderflowVect0:', 1, - 'UnderflowVect1:', 1, - 'UnderflowVect2:', 1, - 'UnderflowVect3:', 1, - 'UnderflowVect4:', 1, - 'UnderflowVect5:', 1, - 'UnderflowVect6:', 1, - 'UnderflowVect7:', 1, - 'UpdErr:', 1, - 'UpdatePAP:', 1, - 'WorldStateToken:', 1, - '_Enter_Internal:', 1, - '_PRMarking_MarkNextAStack:', 1, - '_PRMarking_MarkNextBStack:', 1, - '_PRMarking_MarkNextCAF:', 1, - '_PRMarking_MarkNextGA:', 1, - '_PRMarking_MarkNextRoot:', 1, - '_PRMarking_MarkNextSpark:', 1, - '_Scavenge_Forward_Ref:', 1, - '__std_entry_error__:', 1, - '_startMarkWorld:', 1, - 'resumeThread:', 1, - 'startCcRegisteringWorld:', 1, - 'startEnterFloat:', 1, - 'startEnterInt:', 1, - 'startPerformIO:', 1, - 'startStgWorld:', 1, - 'stopPerformIO:', 1 - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.word\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/ - || $lines[$i] =~ /^\t\.globl/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.word\s+/; $i++) { - push(@words, $lines[$i]); - } - # now throw away the first word (entry code): - shift(@words) if $discard1; - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} - -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc-asm-sgi.prl b/ghc/driver/ghc-asm-sgi.prl deleted file mode 100644 index 2bb357b92e..0000000000 --- a/ghc/driver/ghc-asm-sgi.prl +++ /dev/null @@ -1,69 +0,0 @@ -# line 10 "ghc-asm-sgi.lprl" -sub mangle_asm { - - local($in_asmf, $out_asmf) = @_; - local($fun_code); - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # just copy through now... - while (<INASM>) { - print OUTASM $_; - } - - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -# line 36 "ghc-asm-sgi.lprl" -sub init_FUNNY_THINGS { - print STDERR "SGI: init_FUNNY_THINGS\n"; -} -# line 48 "ghc-asm-sgi.lprl" -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.word\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/ - || $lines[$i] =~ /^\t\.global/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.word\s+/; $i++) { - push(@words, $lines[$i]); - } - # now throw away the first word (entry code): - shift(@words) if $discard1; - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -# line 88 "ghc-asm-sgi.lprl" -# make "require"r happy... -1; diff --git a/ghc/driver/ghc-asm-solaris.lprl b/ghc/driver/ghc-asm-solaris.lprl deleted file mode 100644 index 6359c66c79..0000000000 --- a/ghc/driver/ghc-asm-solaris.lprl +++ /dev/null @@ -1,498 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files (SPARC)} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -(SPARC) [Related] Utterly stomp out the changing of register windows. -\item -Any other required tidying up. -\end{itemize} - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %slowchk = (); # ditto, its regular "slow" entry code - %fastchk = (); # ditto, fast entry code - %closurechk = (); # ditto, the (static) closure - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - %directchk = (); # ditto, direct return code - - $i = 0; - $chkcat[0] = 'misc'; - - while (<INASM>) { - - if ( /^\s+/ ) { # most common case first -- a simple line! - # duplicated from the bottom - - $chk[$i] .= $_; - - } elsif ( /^\.LLC(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'string'; - $chksymb[$i] = $1; - - } elsif ( /^__stg_split_marker(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^([A-Za-z0-9_]+)_info:$/ ) { - $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; - $chksymb[$i] = $1; - - $slowchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_fast\d+:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; - $chksymb[$i] = $1; - - $fastchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)_closure:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^ghc.*c_ID:/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'consist'; - - } elsif ( /^(__gnu_compiled_c|gcc2_compiled\.):/ ) { - ; # toss it - - } elsif ( /^ErrorIO_call_count:/ # HACK!!!! - || /^[A-Za-z0-9_]+\.\d+:$/ - || /_CAT:/ # PROF: _entryname_CAT - || /^CC_.*_struct:/ # PROF: _CC_ccident_struct - || /_done:/ # PROF: _module_done - || /^_module_registered:/ # PROF: _module_registered - ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^(ret_|djn_)/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; - $chksymb[$i] = $1; - - $directchk{$1} = $i; - - } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^[A-Za-z0-9_]/ ) { - local($thing); - chop($thing = $_); - print STDERR "Funny global thing?: $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^_(PRIn|PRStart).*:/ # pointer reversal GC routines - || /^CC_.*:/ # PROF: _CC_ccident - || /^_reg.*:/; # PROF: __reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } else { # simple line (duplicated at the top) - - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - -# print STDERR "\nCLOSURES:\n"; -# foreach $s (sort (keys %closurechk)) { -# print STDERR "$s:\t\t",$closurechk{$s},"\n"; -# } -# print STDERR "\nINFOS:\n"; -# foreach $s (sort (keys %infochk)) { -# print STDERR "$s:\t\t",$infochk{$s},"\n"; -# } -# print STDERR "SLOWS:\n"; -# foreach $s (sort (keys %slowchk)) { -# print STDERR "$s:\t\t",$slowchk{$s},"\n"; -# } -# print STDERR "\nFASTS:\n"; -# foreach $s (sort (keys %fastchk)) { -# print STDERR "$s:\t\t",$fastchk{$s},"\n"; -# } - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - # NB: we start meddling at chunk 1, not chunk 0 - - for ($i = 1; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE):\n", $c; - - # toss all reg-window stuff (save/restore/ret[l] s): - $c =~ s/^\t(save .*|restore|ret|retl)\n//g; - # throw away PROLOGUE comments - $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//; - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - # pick some end-things and move them to the next chunk - - while ( $c =~ /^(\s+\.align\s+\d+\n|\s+\.proc\s+\d+\n|\s+\.global\s+\S+\n|\.text\n|\.data\n|\.stab.*\n|\.section.*\n|\s+\.type.*\n|\s+\.size.*\n)FUNNY#END#THING/ ) { - $to_move = $1; - - if ( $to_move =~ /\.(global|proc|stab)/ && $i < ($numchks - 1) ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/; - } - - $c =~ s/FUNNY#END#THING//; - $chk[$i] = $c; # update w/ convenience copy - } - - # print out all the literal strings first - for ($i = 0; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'string' ) { - print OUTASM "\.text\n\t\.align 8\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - for ($i = 1; $i < $numchks; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM "\.data\n\t\.align 8\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'consist' ) { - if ( $chk[$i] =~ /\.asciz.*\)(hsc|cc) (.*)\\t(.*)"/ ) { - local($consist) = "$1.$2.$3"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - print OUTASM "\.text\n$consist:\n"; - } else { - print STDERR "Couldn't grok consistency: ", $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - print OUTASM "___stg_split_marker",$chksymb[$i],":\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'slow' - || $chkcat[$i] eq 'fast' ) { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM "\.data\n\t\.align 4\n"; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - # entry code will be put here! - - # paranoia - if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/ - && $1 ne "${symb}_entry" ) { - print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; - } - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # STD ENTRY POINT - if ( defined($slowchk{$symb}) ) { - - # teach it to drop through to the fast entry point: - $c = $chk[$slowchk{$symb}]; - - if ( defined($fastchk{$symb}) ) { - $c =~ s/^\tcall ${symb}_fast\d+,.*\n\tnop\n//; - $c =~ s/^\tcall ${symb}_fast\d+,.*\n(\t[a-z].*\n)/\1/; - } - - print STDERR "still has jump to fast entry point:\n$c" - if $c =~ /${symb}_fast/; # NB: paranoia - - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $c; - $chkcat[$slowchk{$symb}] = 'DONE ALREADY'; - } - - # FAST ENTRY POINT - if ( defined($fastchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $chk[$fastchk{$symb}]; - $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' - || $chkcat[$i] eq 'direct' ) { # do them in that order - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - } - - # DIRECT RETURN - if ( defined($directchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $chk[$directchk{$symb}]; - $chkcat[$directchk{$symb}] = 'DONE ALREADY'; - } - - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm SPARC)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - %KNOWN_FUNNY_THING = ( - 'CheckHeapCode:', 1, - 'CommonUnderflow:', 1, - 'Continue:', 1, - 'EnterNodeCode:', 1, - 'ErrorIO_call_count:', 1, - 'ErrorIO_innards:', 1, - 'IndUpdRetDir:', 1, - 'IndUpdRetV0:', 1, - 'IndUpdRetV1:', 1, - 'IndUpdRetV2:', 1, - 'IndUpdRetV3:', 1, - 'IndUpdRetV4:', 1, - 'IndUpdRetV5:', 1, - 'IndUpdRetV6:', 1, - 'IndUpdRetV7:', 1, - 'PrimUnderflow:', 1, - 'StackUnderflowEnterNode:', 1, - 'StdErrorCode:', 1, - 'UnderflowVect0:', 1, - 'UnderflowVect1:', 1, - 'UnderflowVect2:', 1, - 'UnderflowVect3:', 1, - 'UnderflowVect4:', 1, - 'UnderflowVect5:', 1, - 'UnderflowVect6:', 1, - 'UnderflowVect7:', 1, - 'UpdErr:', 1, - 'UpdatePAP:', 1, - 'WorldStateToken:', 1, - '_Enter_Internal:', 1, - '_PRMarking_MarkNextAStack:', 1, - '_PRMarking_MarkNextBStack:', 1, - '_PRMarking_MarkNextCAF:', 1, - '_PRMarking_MarkNextGA:', 1, - '_PRMarking_MarkNextRoot:', 1, - '_PRMarking_MarkNextSpark:', 1, - '_Scavenge_Forward_Ref:', 1, - '__std_entry_error__:', 1, - '_startMarkWorld:', 1, - 'resumeThread:', 1, - 'startCcRegisteringWorld:', 1, - 'startEnterFloat:', 1, - 'startEnterInt:', 1, - 'startPerformIO:', 1, - 'startStgWorld:', 1, - 'stopPerformIO:', 1 - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.word\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/ - || $lines[$i] =~ /^\t\.global/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.word\s+/; $i++) { - push(@words, $lines[$i]); - } - # now throw away the first word (entry code): - shift(@words) if $discard1; - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -%************************************************************************ -%* * -\subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file} -%* * -%************************************************************************ - -How many times is each asm instruction used? - -\begin{code} -%AsmInsn = (); # init - -sub dump_asm_insn_counts { - local($asmf) = @_; - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\t([a-z][a-z0-9]+)\b/ ) { - $AsmInsn{$1} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %AsmInsn)) { - print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n"; - } -} -\end{code} - -How many times is each ``global variable'' used in a \tr{sethi} -instruction (SPARC)? This can give some guidance about what should be -put in machine registers... - -\begin{code} -%SethiGlobal = (); # init - -sub dump_asm_globals_info { - local($asmf) = @_; - - local($globl); - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\tsethi \%hi\(_([_A-Za-z0-9]+)/ ) { - $globl = $1; - next if $globl =~ /(ds|fail|stg|tpl|vtbl)_[0-9]+/; - - $SethiGlobal{$globl} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %SethiGlobal)) { - print STDERR "GLOBAL:: $i\t",$SethiGlobal{$i},"\n"; - } -} - -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc-asm-sparc.lprl b/ghc/driver/ghc-asm-sparc.lprl deleted file mode 100644 index ffe91ae3c6..0000000000 --- a/ghc/driver/ghc-asm-sparc.lprl +++ /dev/null @@ -1,487 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files (SPARC)} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -(SPARC) [Related] Utterly stomp out the changing of register windows. -\item -Any other required tidying up. -\end{itemize} - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - - # multi-line regexp matching: - local($*) = 1; - local($i, $c); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %slowchk = (); # ditto, its regular "slow" entry code - %fastchk = (); # ditto, fast entry code - %closurechk = (); # ditto, the (static) closure - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - %directchk = (); # ditto, direct return code - - $i = 0; - $chkcat[0] = 'misc'; - - while (<INASM>) { - next if /^\.stab.*___stg_split_marker/; - next if /^\.stab.*ghc.*c_ID/; - - if ( /^\s+/ ) { # most common case first -- a simple line! - # duplicated from the bottom - - $chk[$i] .= $_; - - } elsif ( /^LC(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'string'; - $chksymb[$i] = $1; - - } elsif ( /^___stg_split_marker(\d+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^_([A-Za-z0-9_]+)_info:$/ ) { - $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)_entry:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; - $chksymb[$i] = $1; - - $slowchk{$1} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)_fast\d+:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; - $chksymb[$i] = $1; - - $fastchk{$1} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)_closure:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^_ghc.*c_ID:/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'consist'; - - } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.):/ ) { - ; # toss it - - } elsif ( /^_ErrorIO_call_count:/ # HACK!!!! - || /^_[A-Za-z0-9_]+\.\d+:$/ - || /^_.*_CAT:/ # PROF: _entryname_CAT - || /^_CC_.*_struct:/ # PROF: _CC_ccident_struct - || /^_.*_done:/ # PROF: _module_done - || /^__module_registered:/ # PROF: _module_registered - ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^_(ret_|djn_)/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; - $chksymb[$i] = $1; - - $directchk{$1} = $i; - - } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } elsif ( /^_[A-Za-z0-9_]/ ) { - local($thing); - chop($thing = $_); - print STDERR "Funny global thing?: $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^__(PRIn|PRStart).*:/ # pointer reversal GC routines - || /^_CC_.*:/ # PROF: _CC_ccident - || /^__reg.*:/; # PROF: __reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - - } else { # simple line (duplicated at the top) - - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - # NB: we start meddling at chunk 1, not chunk 0 - - for ($i = 1; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE):\n", $c; - - # toss all reg-window stuff (save/restore/ret[l] s): - $c =~ s/^\t(save .*|restore|ret|retl)\n//g; - # throw away PROLOGUE comments - $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//; - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - # pick some end-things and move them to the next chunk - - while ( $c =~ /^(\s+\.align\s+\d+\n|\s+\.proc\s+\d+\n|\s+\.global\s+\S+\n|\.text\n|\.data\n|\.stab.*\n)FUNNY#END#THING/ ) { - $to_move = $1; - - if ( $to_move =~ /\.(global|proc|stab)/ && $i < ($numchks - 1) ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/; - } - - $c =~ s/FUNNY#END#THING//; - $chk[$i] = $c; # update w/ convenience copy - -# print STDERR "\nCHK $i (AFTER):\n", $c; - } - - # print out all the literal strings first - for ($i = 0; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'string' ) { - print OUTASM "\.text\n\t\.align 8\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - for ($i = 0; $i < $numchks; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM "\.data\n\t\.align 8\n"; - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'consist' ) { - if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) { - local($consist) = "$1.$2.$3"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - print OUTASM "\.text\n$consist:\n"; - } else { - print STDERR "Couldn't grok consistency: ", $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - print OUTASM "___stg_split_marker",$chksymb[$i],":\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'slow' - || $chkcat[$i] eq 'fast' ) { # do them in that order - $symb = $chksymb[$i]; - -# print STDERR "$i: cat $chkcat[$i], symb $symb ",defined($closurechk{$symb}),":",defined($infochk{$symb}),":",defined($slowchk{$symb}),":",defined($fastchk{$symb}),"\n"; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM "\.data\n\t\.align 4\n"; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - # entry code will follow, here! - - # paranoia - if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/ - && $1 ne "_${symb}_entry" ) { - print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; - } - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # STD ENTRY POINT - if ( defined($slowchk{$symb}) ) { - - # teach it to drop through to the fast entry point: - $c = $chk[$slowchk{$symb}]; - - if ( defined($fastchk{$symb}) ) { - $c =~ s/^\tcall _${symb}_fast\d+,.*\n\tnop\n//; - $c =~ s/^\tcall _${symb}_fast\d+,.*\n(\t[a-z].*\n)/\1/; - } - - print STDERR "still has jump to fast entry point:\n$c" - if $c =~ /_${symb}_fast/; # NB: paranoia - - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $c; - $chkcat[$slowchk{$symb}] = 'DONE ALREADY'; - } - - # FAST ENTRY POINT - if ( defined($fastchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $chk[$fastchk{$symb}]; - $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' - || $chkcat[$i] eq 'direct' ) { # do them in that order - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - } - - # DIRECT RETURN - if ( defined($directchk{$symb}) ) { - print OUTASM "\.text\n\t\.align 4\n"; - print OUTASM $chk[$directchk{$symb}]; - $chkcat[$directchk{$symb}] = 'DONE ALREADY'; - } - - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm SPARC)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - %KNOWN_FUNNY_THING = ( - '_CheckHeapCode:', 1, - '_CommonUnderflow:', 1, - '_Continue:', 1, - '_EnterNodeCode:', 1, - '_ErrorIO_call_count:', 1, - '_ErrorIO_innards:', 1, - '_IndUpdRetDir:', 1, - '_IndUpdRetV0:', 1, - '_IndUpdRetV1:', 1, - '_IndUpdRetV2:', 1, - '_IndUpdRetV3:', 1, - '_IndUpdRetV4:', 1, - '_IndUpdRetV5:', 1, - '_IndUpdRetV6:', 1, - '_IndUpdRetV7:', 1, - '_PrimUnderflow:', 1, - '_StackUnderflowEnterNode:', 1, - '_StdErrorCode:', 1, - '_UnderflowVect0:', 1, - '_UnderflowVect1:', 1, - '_UnderflowVect2:', 1, - '_UnderflowVect3:', 1, - '_UnderflowVect4:', 1, - '_UnderflowVect5:', 1, - '_UnderflowVect6:', 1, - '_UnderflowVect7:', 1, - '_UpdErr:', 1, - '_UpdatePAP:', 1, - '_WorldStateToken:', 1, - '__Enter_Internal:', 1, - '__PRMarking_MarkNextAStack:', 1, - '__PRMarking_MarkNextBStack:', 1, - '__PRMarking_MarkNextCAF:', 1, - '__PRMarking_MarkNextGA:', 1, - '__PRMarking_MarkNextRoot:', 1, - '__PRMarking_MarkNextSpark:', 1, - '__Scavenge_Forward_Ref:', 1, - '___std_entry_error__:', 1, - '__startMarkWorld:', 1, - '_resumeThread:', 1, - '_startCcRegisteringWorld:', 1, - '_startEnterFloat:', 1, - '_startEnterInt:', 1, - '_startPerformIO:', 1, - '_startStgWorld:', 1, - '_stopPerformIO:', 1 - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - local($symb, $tbl, $discard1) = @_; - - local($before) = ''; - local($label) = ''; - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/, $tbl); - local($i); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.word\s+/; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/ - || $lines[$i] =~ /^\t\.global/; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.word\s+/; $i++) { - push(@words, $lines[$i]); - } - # now throw away the first word (entry code): - shift(@words) if $discard1; - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -%************************************************************************ -%* * -\subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file} -%* * -%************************************************************************ - -How many times is each asm instruction used? - -\begin{code} -%AsmInsn = (); # init - -sub dump_asm_insn_counts { - local($asmf) = @_; - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\t([a-z][a-z0-9]+)\b/ ) { - $AsmInsn{$1} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %AsmInsn)) { - print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n"; - } -} -\end{code} - -How many times is each ``global variable'' used in a \tr{sethi} -instruction (SPARC)? This can give some guidance about what should be -put in machine registers... - -\begin{code} -%SethiGlobal = (); # init - -sub dump_asm_globals_info { - local($asmf) = @_; - - local($globl); - - open(INASM, "< $asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n"); - while (<INASM>) { - if ( /^\tsethi \%hi\(_([_A-Za-z0-9]+)/ ) { - $globl = $1; - next if $globl =~ /(ds|fail|stg|tpl|vtbl)_[0-9]+/; - - $SethiGlobal{$globl} ++; - } - } - close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n"); - - # OK, now print what we collected (to stderr) - foreach $i (sort (keys %SethiGlobal)) { - print STDERR "GLOBAL:: $i\t",$SethiGlobal{$i},"\n"; - } -} - -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc-asm.lprl b/ghc/driver/ghc-asm.lprl index 4a4834cea4..0907b0945c 100644 --- a/ghc/driver/ghc-asm.lprl +++ b/ghc/driver/ghc-asm.lprl @@ -13,6 +13,33 @@ stuff to do with the C stack. Any other required tidying up. \end{itemize} +HPPA specific notes: +\begin{itemize} +\item +The HP linker is very picky about symbols being in the appropriate +space (code vs. data). When we mangle the threaded code to put the +info tables just prior to the code, they wind up in code space +rather than data space. This means that references to *_info from +un-mangled parts of the RTS (e.g. unthreaded GC code) get +unresolved symbols. Solution: mini-mangler for .c files on HP. I +think this should really be triggered in the driver by a new -rts +option, so that user code doesn't get mangled inappropriately. +\item +With reversed tables, jumps are to the _info label rather than to +the _entry label. The _info label is just an address in code +space, rather than an entry point with the descriptive blob we +talked about yesterday. As a result, you can't use the call-style +JMP_ macro. However, some JMP_ macros take _info labels as targets +and some take code entry points within the RTS. The latter won't +work with the goto-style JMP_ macro. Sigh. Solution: Use the goto +style JMP_ macro, and mangle some more assembly, changing all +"RP'literal" and "LP'literal" references to "R'literal" and +"L'literal," so that you get the real address of the code, rather +than the descriptive blob. Also change all ".word P%literal" +entries in info tables and vector tables to just ".word literal," +for the same reason. Advantage: No more ridiculous call sequences. +\end{itemize} + %************************************************************************ %* * \subsection{Constants for various architectures} @@ -22,7 +49,62 @@ Any other required tidying up. \begin{code} sub init_TARGET_STUFF { - if ( $TargetPlatform =~ /^i386-.*-linuxaout/ ) { + #--------------------------------------------------------# + if ( $TargetPlatform =~ /^alpha-.*-.*/ ) { + + $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) + $T_US = ''; # _ if symbols have an underscore on the front + $T_DO_GC = 'PerformGC_wrapper'; + $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP + $T_CONST_LBL = '^\$C(\d+):$'; # regexp for what such a lbl looks like + $T_POST_LBL = ':'; + + $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)'; + $T_COPY_DIRVS = '^\s*(\#|\.(file|globl|ent|loc))'; + + $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"'; + $T_DOT_WORD = '\.quad'; + $T_DOT_GLOBAL = "\t\.globl"; + $T_HDR_literal = "\.rdata\n\t\.align 3\n"; + $T_HDR_misc = "\.text\n\t\.align 3\n"; + $T_HDR_data = "\.data\n\t\.align 3\n"; + $T_HDR_consist = "\.text\n"; + $T_HDR_closure = "\.data\n\t\.align 3\n"; + $T_HDR_info = "\.text\n\t\.align 3\n"; + $T_HDR_entry = "\.text\n\t\.align 3\n"; + $T_HDR_fast = "\.text\n\t\.align 3\n"; + $T_HDR_vector = "\.text\n\t\.align 3\n"; + $T_HDR_direct = "\.text\n\t\.align 3\n"; + + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^hppa/ ) { + + $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) + $T_US = ''; # _ if symbols have an underscore on the front + $T_DO_GC = 'PerformGC_wrapper'; + $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP + $T_CONST_LBL = '^L\$C(\d+)$'; # regexp for what such a lbl looks like + $T_POST_LBL = ''; + + $T_MOVE_DIRVS = '^((\s+\.(IMPORT|EXPORT|PARAM).*|\s+\.align\s+\d+|\s+\.(SPACE|SUBSPA)\s+\S+|\s*)\n)'; + $T_COPY_DIRVS = '^\s+\.(IMPORT|EXPORT)'; + + $T_hsc_cc_PAT = '\.STRING.*\)(hsc|cc) (.*)\\\\x09(.*)\\\\x00'; + $T_DOT_WORD = '\.word'; + $T_DOT_GLOBAL = '\s+\.EXPORT'; + $T_HDR_literal = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n"; + $T_HDR_misc = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + $T_HDR_data = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; + $T_HDR_consist = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n"; + $T_HDR_closure = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; + $T_HDR_info = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + $T_HDR_entry = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + $T_HDR_fast = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + $T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + $T_HDR_direct = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd)/ ) { $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) $T_US = '_'; # _ if symbols have an underscore on the front @@ -30,26 +112,28 @@ sub init_TARGET_STUFF { $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP $T_CONST_LBL = '^LC(\d+):$'; $T_POST_LBL = ':'; - $T_PRE_LLBL_PAT = 'L'; - $T_PRE_LLBL = 'L'; + $T_X86_PRE_LLBL_PAT = 'L'; + $T_X86_PRE_LLBL = 'L'; $T_X86_BADJMP = '^\tjmp [^L\*]'; - $T_MOVE_DIRVS = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.stab[^n].*\n)'; + $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+(,0x90)?|\.globl\s+\S+|\.text|\.data|\.stab[^n].*|\.type\s+.*|\.size\s+.*)\n)'; $T_COPY_DIRVS = '\.(globl|stab)'; $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"'; $T_DOT_WORD = '\.long'; - $T_HDR_string = "\.text\n\t\.align 4\n"; # .align 4 is 486-cache friendly - $T_HDR_misc = "\.text\n\t\.align 4\n"; + $T_DOT_GLOBAL = '\.globl'; + $T_HDR_literal = "\.text\n\t\.align 2\n"; # .align 4 is 486-cache friendly + $T_HDR_misc = "\.text\n\t\.align 2,0x90\n"; $T_HDR_data = "\.data\n\t\.align 2\n"; # ToDo: change align?? $T_HDR_consist = "\.text\n"; $T_HDR_closure = "\.data\n\t\.align 2\n"; # ToDo: change align? - $T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding + $T_HDR_info = "\.text\n\t\.align 2\n"; # NB: requires padding $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?) - $T_HDR_fast = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding - $T_HDR_direct = "\.text\n\t\.align 4\n"; + $T_HDR_fast = "\.text\n\t\.align 2,0x90\n"; + $T_HDR_vector = "\.text\n\t\.align 2\n"; # NB: requires padding + $T_HDR_direct = "\.text\n\t\.align 2,0x90\n"; - } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/ ) { + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux)$/ ) { $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) $T_US = ''; # _ if symbols have an underscore on the front @@ -57,16 +141,17 @@ sub init_TARGET_STUFF { $T_PRE_APP = '/'; # regexp that says what comes before APP/NO_APP $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like $T_POST_LBL = ':'; - $T_PRE_LLBL_PAT = '\.L'; - $T_PRE_LLBL = '.L'; + $T_X86_PRE_LLBL_PAT = '\.L'; + $T_X86_PRE_LLBL = '.L'; $T_X86_BADJMP = '^\tjmp [^\.\*]'; - $T_MOVE_DIRVS = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.section\s+.*\n|\.type\s+.*\n|\.Lfe.*\n\t\.size\s+.*\n|\.size\s+.*\n|\.ident.*\n)'; + $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+(,0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.Lfe.*\n\t\.size\s+.*|\.size\s+.*|\.ident.*)\n)'; $T_COPY_DIRVS = '\.(globl)'; $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"'; $T_DOT_WORD = '\.long'; - $T_HDR_string = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11) + $T_DOT_GLOBAL = '\.globl'; + $T_HDR_literal = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11) $T_HDR_misc = "\.text\n\t\.align 16\n"; $T_HDR_data = "\.data\n\t\.align 4\n"; # ToDo: change align?? $T_HDR_consist = "\.text\n"; @@ -77,6 +162,61 @@ sub init_TARGET_STUFF { $T_HDR_vector = "\.text\n\t\.align 16\n"; # NB: requires padding $T_HDR_direct = "\.text\n\t\.align 16\n"; + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/ ) { + + $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) + $T_US = '_'; # _ if symbols have an underscore on the front + $T_DO_GC = '_PerformGC_wrapper'; + $T_PRE_APP = '^# MAY NOT APPLY'; # regexp that says what comes before APP/NO_APP + $T_CONST_LBL = '^LC(\d+):$'; + $T_POST_LBL = ':'; + + $T_MOVE_DIRVS = '(\s*(\.align\s+\d+|\.proc\s+\d+|\.const|\.cstring|\.globl\s+\S+|\.text|\.data|\.even|\.stab[^n].*)\n)'; + $T_COPY_DIRVS = '\.(globl|proc|stab)'; + $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"'; + + $T_DOT_WORD = '\.long'; + $T_DOT_GLOBAL = '\.globl'; + $T_HDR_literal = "\.text\n\t\.even\n"; + $T_HDR_misc = "\.text\n\t\.even\n"; + $T_HDR_data = "\.data\n\t\.even\n"; + $T_HDR_consist = "\.text\n"; + $T_HDR_closure = "\.data\n\t\.even\n"; + $T_HDR_info = "\.text\n\t\.even\n"; + $T_HDR_entry = "\.text\n\t\.even\n"; + $T_HDR_fast = "\.text\n\t\.even\n"; + $T_HDR_vector = "\.text\n\t\.even\n"; + $T_HDR_direct = "\.text\n\t\.even\n"; + + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^mips-.*/ ) { + + $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) + $T_US = ''; # _ if symbols have an underscore on the front + $T_DO_GC = 'PerformGC_wrapper'; + $T_PRE_APP = '^\s*#'; # regexp that says what comes before APP/NO_APP + $T_CONST_LBL = '^\$LC(\d+):$'; # regexp for what such a lbl looks like + $T_POST_LBL = ':'; + + $T_MOVE_DIRVS = '(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\.text|\.r?data)\n)'; + $T_COPY_DIRVS = '\.(globl|ent)'; + + $T_hsc_cc_PAT = 'I WAS TOO LAZY TO DO THIS BIT (WDP 95/05)'; + $T_DOT_WORD = '\.word'; + $T_DOT_GLOBAL = '\t\.globl'; + $T_HDR_literal = "\t\.rdata\n\t\.align 2\n"; + $T_HDR_misc = "\t\.text\n\t\.align 2\n"; + $T_HDR_data = "\t\.data\n\t\.align 2\n"; + $T_HDR_consist = 'TOO LAZY TO DO THIS TOO'; + $T_HDR_closure = "\t\.data\n\t\.align 2\n"; + $T_HDR_info = "\t\.text\n\t\.align 2\n"; + $T_HDR_entry = "\t\.text\n\t\.align 2\n"; + $T_HDR_fast = "\t\.text\n\t\.align 2\n"; + $T_HDR_vector = "\t\.text\n\t\.align 2\n"; + $T_HDR_direct = "\t\.text\n\t\.align 2\n"; + + #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^powerpc-.*/ ) { $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) @@ -85,16 +225,14 @@ sub init_TARGET_STUFF { $T_PRE_APP = 'NOT APPLICABLE'; # regexp that says what comes before APP/NO_APP $T_CONST_LBL = '^LC\.\.(\d+):$'; # regexp for what such a lbl looks like $T_POST_LBL = ':'; - $T_PRE_LLBL_PAT = '\.L'; - $T_PRE_LLBL = '.L'; - $T_X86_BADJMP = 'NOT APPLICABLE'; - $T_MOVE_DIRVS = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.section\s+.*\n|\.type\s+.*\n|\.Lfe.*\n\t\.size\s+.*\n|\.size\s+.*\n|\.ident.*\n)'; + $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+(,0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.Lfe.*\n\t\.size\s+.*|\.size\s+.*|\.ident.*)\n)'; $T_COPY_DIRVS = '\.(globl)'; $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"'; $T_DOT_WORD = '\.long'; - $T_HDR_string = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11) + $T_DOT_GLOBAL = '\.globl'; + $T_HDR_literal = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11) $T_HDR_misc = "\.text\n\t\.align 16\n"; $T_HDR_data = "\.data\n\t\.align 4\n"; # ToDo: change align?? $T_HDR_consist = "\.text\n"; @@ -104,6 +242,65 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.align 16\n"; $T_HDR_vector = "\.text\n\t\.align 16\n"; # NB: requires padding $T_HDR_direct = "\.text\n\t\.align 16\n"; + + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^sparc-.*-solaris2/ ) { + + $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) + $T_US = ''; # _ if symbols have an underscore on the front + $T_DO_GC = 'PerformGC_wrapper'; + $T_PRE_APP = 'DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP + $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like + $T_POST_LBL = ':'; + + $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*|\.section.*|\s+\.type.*|\s+\.size.*)\n)'; + $T_COPY_DIRVS = '\.(global|proc|stab)'; + + $T_hsc_cc_PAT = '\.asciz.*\)(hsc|cc) (.*)\\\\t(.*)"'; + $T_DOT_WORD = '\.word'; + $T_DOT_GLOBAL = '\.global'; + $T_HDR_literal = "\.text\n\t\.align 8\n"; + $T_HDR_misc = "\.text\n\t\.align 4\n"; + $T_HDR_data = "\.data\n\t\.align 8\n"; + $T_HDR_consist = "\.text\n"; + $T_HDR_closure = "\.data\n\t\.align 4\n"; + $T_HDR_info = "\.text\n\t\.align 4\n"; + $T_HDR_entry = "\.text\n\t\.align 4\n"; + $T_HDR_fast = "\.text\n\t\.align 4\n"; + $T_HDR_vector = "\.text\n\t\.align 4\n"; + $T_HDR_direct = "\.text\n\t\.align 4\n"; + + #--------------------------------------------------------# + } elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/ ) { + + $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) + $T_US = '_'; # _ if symbols have an underscore on the front + $T_DO_GC = '_PerformGC_wrapper'; + $T_PRE_APP = '^# DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP + $T_CONST_LBL = '^LC(\d+):$'; + $T_POST_LBL = ':'; + + $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*)\n)'; + $T_COPY_DIRVS = '\.(global|proc|stab)'; + $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"'; + + $T_DOT_WORD = '\.word'; + $T_DOT_GLOBAL = '^\t\.global'; + $T_HDR_literal = "\.text\n\t\.align 8\n"; + $T_HDR_misc = "\.text\n\t\.align 4\n"; + $T_HDR_data = "\.data\n\t\.align 8\n"; + $T_HDR_consist = "\.text\n"; + $T_HDR_closure = "\.data\n\t\.align 4\n"; + $T_HDR_info = "\.text\n\t\.align 4\n"; + $T_HDR_entry = "\.text\n\t\.align 4\n"; + $T_HDR_fast = "\.text\n\t\.align 4\n"; + $T_HDR_vector = "\.text\n\t\.align 4\n"; + $T_HDR_direct = "\.text\n\t\.align 4\n"; + + #--------------------------------------------------------# + } else { + print STDERR "$Pgm: don't know how to mangle assembly language for: $TargetPlatform\n"; + exit 1; } if ( 0 ) { @@ -113,15 +310,16 @@ print STDERR "T_DO_GC: $T_DO_GC\n"; print STDERR "T_PRE_APP: $T_PRE_APP\n"; print STDERR "T_CONST_LBL: $T_CONST_LBL\n"; print STDERR "T_POST_LBL: $T_POST_LBL\n"; -print STDERR "T_PRE_LLBL_PAT: $T_PRE_LLBL_PAT\n"; -print STDERR "T_PRE_LLBL: $T_PRE_LLBL\n"; -print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n"; - +if ( $TargetPlatform =~ /^i386-/ ) { + print STDERR "T_X86_PRE_LLBL_PAT: $T_X86_PRE_LLBL_PAT\n"; + print STDERR "T_X86_PRE_LLBL: $T_X86_PRE_LLBL\n"; + print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n"; +} print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n"; print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n"; print STDERR "T_hsc_cc_PAT: $T_hsc_cc_PAT\n"; print STDERR "T_DOT_WORD: $T_DOT_WORD\n"; -print STDERR "T_HDR_string: $T_HDR_string\n"; +print STDERR "T_HDR_literal: $T_HDR_literal\n"; print STDERR "T_HDR_misc: $T_HDR_misc\n"; print STDERR "T_HDR_data: $T_HDR_data\n"; print STDERR "T_HDR_consist: $T_HDR_consist\n"; @@ -170,34 +368,52 @@ sub mangle_asm { %infochk = (); # given a symbol base, say what chunk its info tbl is in %vectorchk = (); # ditto, return vector table %directchk = (); # ditto, direct return code + $EXTERN_DECLS = ''; # .globl <foo> .text (MIPS only) - $i = 0; - $chkcat[0] = 'misc'; + $i = 0; $chkcat[0] = 'misc'; $chk[0] = ''; while (<INASM>) { next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o; next if $T_STABBY && /^\.stab.*ghc.*c_ID/; next if /${T_PRE_APP}(NO_)?APP/o; - if ( /^\s+/ ) { # most common case first -- a simple line! + next if /^;/ && $TargetPlatform =~ /^hppa/; + + next if /(^$|^\t\.file\t|^ # )/ && $TargetPlatform =~ /^mips-/; + + if ( $TargetPlatform =~ /^mips-/ + && /^\t\.(globl \S+ \.text|comm\t)/ ) { + $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/; + + } elsif ( /^\s+/ ) { # most common case first -- a simple line! # duplicated from the bottom $chk[$i] .= $_; + } elsif ( /\.\.ng:$/ && $TargetPlatform =~ /^alpha-/ ) { + # Alphas: Local labels not to be confused with new chunks + $chk[$i] .= $_; + + # NB: all the rest start with a non-space + + } elsif ( $TargetPlatform =~ /^mips-/ + && /^\d+:/ ) { # a funny-looking very-local label + $chk[$i] .= $_; + } elsif ( /$T_CONST_LBL/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'string'; + $chk[++$i] = $_; + $chkcat[$i] = 'literal'; $chksymb[$i] = $1; } elsif ( /^${T_US}__stg_split_marker(\d+)${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'splitmarker'; + $chk[++$i] = $_; + $chkcat[$i] = 'splitmarker'; $chksymb[$i] = $1; } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/o ) { $symb = $1; - $chk[++$i] .= $_; - $chkcat[$i] = 'infotbl'; + $chk[++$i] = $_; + $chkcat[$i] = 'infotbl'; $chksymb[$i] = $symb; die "Info table already? $symb; $i\n" if defined($infochk{$symb}); @@ -205,31 +421,31 @@ sub mangle_asm { $infochk{$symb} = $i; } elsif ( /^${T_US}([A-Za-z0-9_]+)_entry${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'slow'; + $chk[++$i] = $_; + $chkcat[$i] = 'slow'; $chksymb[$i] = $1; $slowchk{$1} = $i; } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d+${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'fast'; + $chk[++$i] = $_; + $chkcat[$i] = 'fast'; $chksymb[$i] = $1; $fastchk{$1} = $i; } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'closure'; + $chk[++$i] = $_; + $chkcat[$i] = 'closure'; $chksymb[$i] = $1; $closurechk{$1} = $i; } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) { - $chk[++$i] .= $_; + $chk[++$i] = $_; $chkcat[$i] = 'consist'; - } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) { + } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) { ; # toss it } elsif ( /^${T_US}ErrorIO_call_count${T_POST_LBL}$/o # HACK!!!! @@ -239,32 +455,37 @@ sub mangle_asm { || /^${T_US}.*_done${T_POST_LBL}$/o # PROF: _module_done || /^${T_US}_module_registered${T_POST_LBL}$/o # PROF: _module_registered ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'data'; + $chk[++$i] = $_; + $chkcat[$i] = 'data'; $chksymb[$i] = ''; + } elsif ( /^([A-Za-z0-9_]+)\s+\.comm/ && $TargetPlatform =~ /^hppa/ ) { + $chk[++$i] = $_; + $chkcat[$i] = 'bss'; + $chksymb[$i] = $1; + } elsif ( /^${T_US}(ret_|djn_)/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; + $chk[++$i] = $_; + $chkcat[$i] = 'misc'; $chksymb[$i] = ''; } elsif ( /^${T_US}vtbl_([A-Za-z0-9_]+)${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'vector'; + $chk[++$i] = $_; + $chkcat[$i] = 'vector'; $chksymb[$i] = $1; $vectorchk{$1} = $i; } elsif ( /^${T_US}([A-Za-z0-9_]+)DirectReturn${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'direct'; + $chk[++$i] = $_; + $chkcat[$i] = 'direct'; $chksymb[$i] = $1; $directchk{$1} = $i; } elsif ( /^${T_US}[A-Za-z0-9_]+_upd${T_POST_LBL}$/o ) { - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; + $chk[++$i] = $_; + $chkcat[$i] = 'misc'; $chksymb[$i] = ''; } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/ @@ -278,20 +499,22 @@ sub mangle_asm { # Haskell, make a call to your own C wrapper, then # put that C wrapper (which calls one of these) in a # plain .c file. WDP 95/12 - $chk[++$i] .= $_; - $chkcat[$i] = 'toss'; + $chk[++$i] = $_; + $chkcat[$i] = 'toss'; $chksymb[$i] = $1; - } elsif ( /^${T_US}[A-Za-z0-9_]/o ) { + } elsif ( /^${T_US}[A-Za-z0-9_]/o + && ( $TargetPlatform !~ /^hppa/ # need to avoid local labels in this case + || /^L\$\d+$/ ) ) { local($thing); chop($thing = $_); print STDERR "Funny global thing?: $_" unless $KNOWN_FUNNY_THING{$thing} || /^${T_US}_(PRIn|PRStart).*${T_POST_LBL}$/o # pointer reversal GC routines - || /^${T_US}CC_.*${T_POST_LBL}$/ # PROF: _CC_ccident - || /^${T_US}_reg.*${T_POST_LBL}$/; # PROF: __reg<module> - $chk[++$i] .= $_; - $chkcat[$i] = 'misc'; + || /^${T_US}CC_.*${T_POST_LBL}$/o # PROF: _CC_ccident + || /^${T_US}_reg.*${T_POST_LBL}$/o; # PROF: __reg<module> + $chk[++$i] = $_; + $chkcat[$i] = 'misc'; $chksymb[$i] = ''; } else { # simple line (duplicated at the top) @@ -309,19 +532,58 @@ sub mangle_asm { # about the whole module before we start spitting # output. - for ($i = 0; $i < $numchks; $i++) { + local($FIRST_MANGLABLE) = ($TargetPlatform =~ /^(alpha-|hppa|mips-)/) ? 1 : 0; + +# print STDERR "first chunk to mangle: $FIRST_MANGLABLE\n"; + + # Alphas: NB: we start meddling at chunk 1, not chunk 0 + # The first ".rdata" is quite magical; as of GCC 2.7.x, it + # spits a ".quad 0" in after the v first ".rdata"; we + # detect this special case (tossing the ".quad 0")! + local($magic_rdata_seen) = 0; + + # HPPAs, MIPSen: also start medding at chunk 1 + + for ($i = $FIRST_MANGLABLE; $i < $numchks; $i++) { $c = $chk[$i]; # convenience copy # print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c; - # toss all prologue stuff; + # toss all prologue stuff; HPPA is pretty weird + # (see elsewhere) + $c = &mash_hppa_prologue($c) if $TargetPlatform =~ /^hppa/; + # be slightly paranoid to make sure there's # nothing surprising in there if ( $c =~ /--- BEGIN ---/ ) { if (($p, $r) = split(/--- BEGIN ---/, $c)) { - $p =~ s/^\tpushl \%edi\n//; - $p =~ s/^\tpushl \%esi\n//; - $p =~ s/^\tsubl \$\d+,\%esp\n//; + + if ($TargetPlatform =~ /^i386-/) { + $p =~ s/^\tpushl \%edi\n//; + $p =~ s/^\tpushl \%esi\n//; + $p =~ s/^\tsubl \$\d+,\%esp\n//; + } elsif ($TargetPlatform =~ /^m68k-/) { + $p =~ s/^\tlink a6,#-?\d.*\n//; + $p =~ s/^\tmovel d2,sp\@-\n//; + $p =~ s/^\tmovel d5,sp\@-\n//; # SMmark.* only? + $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//; # SMmark.* only? + } elsif ($TargetPlatform =~ /^mips-/) { + # the .frame/.mask/.fmask that we use is the same + # as that produced by GCC for miniInterpret; this + # gives GDB some chance of figuring out what happened + $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n"; + $p =~ s/^\t\.(frame).*\n/__FRAME__/g; + $p =~ s/^\t\.(mask|fmask).*\n//g; + $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/; # 16 + 100 4-byte args + $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//; + $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//; + $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//; + $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//; + $p =~ s/__FRAME__/$FRAME/; + } else { + print STDERR "$Pgm: unknown prologue mangling? $TargetPlatform\n"; + } + die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/; # glue together what's left @@ -332,29 +594,71 @@ sub mangle_asm { # toss all epilogue stuff; again, paranoidly if ( $c =~ /--- END ---/ ) { if (($r, $e) = split(/--- END ---/, $c)) { - $e =~ s/^\tret\n//; - $e =~ s/^\tpopl \%edi\n//; - $e =~ s/^\tpopl \%esi\n//; - $e =~ s/^\taddl \$\d+,\%esp\n//; + if ($TargetPlatform =~ /^i386-/) { + $e =~ s/^\tret\n//; + $e =~ s/^\tpopl \%edi\n//; + $e =~ s/^\tpopl \%esi\n//; + $e =~ s/^\taddl \$\d+,\%esp\n//; + } elsif ($TargetPlatform =~ /^m68k-/) { + $e =~ s/^\tunlk a6\n//; + $e =~ s/^\trts\n//; + } elsif ($TargetPlatform =~ /^mips-/) { + $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//; + $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//; + $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//; + $e =~ s/^\tj\t\$31\n//; + } else { + print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n"; + } die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/; # glue together what's left $c = $r . $e; + $c =~ s/\n\t\n/\n/; # junk blank line } } + # On SPARCs, we don't do --- BEGIN/END ---, we just + # toss the register-windowing save/restore/ret* instructions + # directly: + if ( $TargetPlatform =~ /^sparc-/ ) { + $c =~ s/^\t(save .*|restore|ret|retl)\n//g; + # throw away PROLOGUE comments + $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//; + } + + # On Alphas, the prologue mangling is done a little later (below) + # toss all calls to __DISCARD__ - $c =~ s/^\tcall ${T_US}__DISCARD__\n//go; + $c =~ s/^\t(call|jbsr|jal) ${T_US}__DISCARD__\n//go; + + # MIPS: that may leave some gratuitous asm macros around + # (no harm done; but we get rid of them to be tidier) + $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/ + if $TargetPlatform =~ /^mips-/; + + # toss stack adjustment after DoSparks + $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/g + if $TargetPlatform =~ /^m68k-/; # this looks old... + + if ( $TargetPlatform =~ /^alpha-/ && + ! $magic_rdata_seen && + $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/ ) { + $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/; + $magic_rdata_seen = 1; + } + + # pick some end-things and move them to the next chunk # pin a funny end-thing on (for easier matching): $c .= 'FUNNY#END#THING'; - # pick some end-things and move them to the next chunk - while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/o ) { $to_move = $1; - if ( $to_move =~ /${T_COPY_DIRVS}/ && $i < ($numchks - 1) ) { + if ( $i < ($numchks - 1) + && ( $to_move =~ /${T_COPY_DIRVS}/ + || ($TargetPlatform =~ /^hppa/ && $to_move =~ /align/ && $chkcat[$i+1] eq 'literal') )) { $chk[$i + 1] = $to_move . $chk[$i + 1]; # otherwise they're tossed } @@ -362,6 +666,19 @@ sub mangle_asm { $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/o; } + if ( $TargetPlatform =~ /^alpha-/ && $c =~ /^\t\.ent\s+(\S+)/ ) { + $ent = $1; + # toss all prologue stuff, except for loading gp, and the ..ng address + if (($p, $r) = split(/^\t\.prologue/, $c)) { + if (($keep, $junk) = split(/\.\.ng:/, $p)) { + $c = $keep . "..ng:\n"; + } else { + print STDERR "malformed code block ($ent)?\n" + } + } + $c .= "\t.frame \$30,0,\$26,0\n\t.prologue" . $r; + } + $c =~ s/FUNNY#END#THING//; # print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c; @@ -369,30 +686,78 @@ sub mangle_asm { $chk[$i] = $c; # update w/ convenience copy } - # print out all the literal strings first + if ( $TargetPlatform =~ /^alpha-/ ) { + # print out the header stuff first + $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/$1"$ifile_root.hc"/; + print OUTASM $chk[0]; + + } elsif ( $TargetPlatform =~ /^hppa/ ) { + print OUTASM $chk[0]; + + } elsif ( $TargetPlatform =~ /^mips-/ ) { + $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0]; + + # get rid of horrible "<dollar>Revision: .*$" strings + local(@lines0) = split(/\n/, $chk[0]); + local($z) = 0; + while ( $z <= $#lines0 ) { + if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/ ) { + undef($lines0[$z]); + $z++; + while ( $z <= $#lines0 ) { + undef($lines0[$z]); + last if $lines0[$z] =~ /[,\t]0x0$/; + $z++; + } + } + $z++; + } + $chk[0] = join("\n", @lines0); + $chk[0] =~ s/\n\n+/\n/; + print OUTASM $chk[0]; + } + + # print out all the literal strings next for ($i = 0; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'string' ) { - print OUTASM $T_HDR_string, $chk[$i]; - + if ( $chkcat[$i] eq 'literal' ) { + print OUTASM $T_HDR_literal, $chk[$i]; + print OUTASM "; end literal\n" if $TargetPlatform =~ /^hppa/; # for the splitter + $chkcat[$i] = 'DONE ALREADY'; } } - for ($i = 0; $i < $numchks; $i++) { + # on the HPPA, print out all the bss next + if ( $TargetPlatform =~ /^hppa/ ) { + for ($i = 1; $i < $numchks; $i++) { + if ( $chkcat[$i] eq 'bss' ) { + print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$BSS\$\n\t.align 4\n"; + print OUTASM $chk[$i]; + + $chkcat[$i] = 'DONE ALREADY'; + } + } + } + + for ($i = $FIRST_MANGLABLE; $i < $numchks; $i++) { # print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; next if $chkcat[$i] eq 'DONE ALREADY'; if ( $chkcat[$i] eq 'misc' ) { - print OUTASM $T_HDR_misc; - &print_doctored($chk[$i], 0); + if ($chk[$i] ne '') { + print OUTASM $T_HDR_misc; + &print_doctored($chk[$i], 0); + } } elsif ( $chkcat[$i] eq 'toss' ) { print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n"; } elsif ( $chkcat[$i] eq 'data' ) { - print OUTASM $T_HDR_data; - print OUTASM $chk[$i]; + if ($chk[$i] ne '') { + print OUTASM $T_HDR_data; + print OUTASM $chk[$i]; + } } elsif ( $chkcat[$i] eq 'consist' ) { if ( $chk[$i] =~ /$T_hsc_cc_PAT/o ) { @@ -401,14 +766,17 @@ sub mangle_asm { $consist =~ s/\//./g; $consist =~ s/-/_/g; $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - print OUTASM $T_HDR_consist, "${consist}${T_POST_LBL}\n"; + print OUTASM $T_HDR_consist, "${consist}${T_POST_LBL}\n" + if $TargetPlatform !~ /^mips-/; # we just don't try in that case } else { print STDERR "Couldn't grok consistency: ", $chk[$i]; } } elsif ( $chkcat[$i] eq 'splitmarker' ) { # we can just re-constitute this one... - print OUTASM "${T_US}__stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n"; + # NB: we emit _three_ underscores no matter what, + # so ghc-split doesn't have to care. + print OUTASM "___stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n"; } elsif ( $chkcat[$i] eq 'closure' || $chkcat[$i] eq 'infotbl' @@ -446,12 +814,33 @@ sub mangle_asm { $c = $chk[$slowchk{$symb}]; if ( defined($fastchk{$symb}) ) { - $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%edx\n\tjmp \*\%edx\n//; - $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%eax\n\tjmp \*\%eax\n//; + if ( $TargetPlatform =~ /^alpha-/ ) { + $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/; + } elsif ( $TargetPlatform =~ /^hppa/ ) { + $c =~ s/^\s+ldil.*\n\s+ldo.*\n\s+bv.*\n(.*\n)?\s+\.EXIT/$1\t.EXIT/; + } elsif ( $TargetPlatform =~ /^i386-/ ) { + $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%edx\n\tjmp \*\%edx\n//; + $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%eax\n\tjmp \*\%eax\n//; + } elsif ( $TargetPlatform =~ /^mips-/ ) { + $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/; + } elsif ( $TargetPlatform =~ /^m68k-/ ) { + $c =~ s/^\tjmp ${T_US}${symb}_fast\d+.*\n\tnop\n//; + $c =~ s/^\tjmp ${T_US}${symb}_fast\d+.*\n//; + } elsif ( $TargetPlatform =~ /^sparc-/ ) { + $c =~ s/^\tcall ${T_US}${symb}_fast\d+,.*\n\tnop\n//; + $c =~ s/^\tcall ${T_US}${symb}_fast\d+,.*\n(\t[a-z].*\n)/$1/; + } else { + print STDERR "$Pgm: mystery slow-fast dropthrough: $TargetPlatform\n"; + } } - print STDERR "still has jump to fast entry point:\n$c" - if $c =~ /${T_US}${symb}_fast/; # NB: paranoia + if ( $TargetPlatform !~ /^(alpha-|hppa|mips-)/ ) { + # On alphas, hppa: no very good way to look for "dangling" + # references to fast-entry point. + # (questionable re hppa and mips...) + print STDERR "still has jump to fast entry point:\n$c" + if $c =~ /${T_US}${symb}_fast/; # NB: paranoia + } print OUTASM $T_HDR_entry; @@ -462,7 +851,13 @@ sub mangle_asm { # FAST ENTRY POINT if ( defined($fastchk{$symb}) ) { - print OUTASM $T_HDR_fast; + if ( ! defined($slowchk{$symb}) + # ToDo: the || clause can go once we're no longer + # concerned about producing exactly the same output as before + || $TargetPlatform =~ /^(m68k|sparc|i386)-/ + ) { + print OUTASM $T_HDR_fast; + } &print_doctored($chk[$fastchk{$symb}], 0); $chkcat[$fastchk{$symb}] = 'DONE ALREADY'; } @@ -484,6 +879,15 @@ sub mangle_asm { print OUTASM $T_HDR_direct; &print_doctored($chk[$directchk{$symb}], 0); $chkcat[$directchk{$symb}] = 'DONE ALREADY'; + + } elsif ( $TargetPlatform =~ /^alpha-/ ) { + # Alphas: the commented nop is for the splitter, to ensure + # that no module ends with a label as the very last + # thing. (The linker will adjust the label to point + # to the first code word of the next module linked in, + # even if alignment constraints cause the label to move!) + + print OUTASM "\t# nop\n"; } } else { @@ -497,6 +901,31 @@ sub mangle_asm { \end{code} \begin{code} +sub mash_hppa_prologue { # OK, epilogue, too + local($_) = @_; + + # toss all prologue stuff + s/^\s+\.ENTRY[^\0]*--- BEGIN ---/\t.ENTRY/; + + # Lie about our .CALLINFO + s/^\s+\.CALLINFO.*$/\t.CALLINFO NO_CALLS,NO_UNWIND/; + + # Get rid of P' + + s/LP'/L'/g; + s/RP'/R'/g; + + # toss all epilogue stuff + s/^\s+--- END ---[^\0]*\.EXIT/\t.EXIT/; + + # Sorry; we moved the _info stuff to the code segment. + s/_info,DATA/_info,CODE/g; + + return($_); +} +\end{code} + +\begin{code} sub print_doctored { local($_, $need_fallthru_patch) = @_; @@ -631,13 +1060,13 @@ sub print_doctored { # fix _all_ non-local jumps: - s/^\tjmp \*${T_PRE_LLBL_PAT}/\tJMP___SL/go; - s/^\tjmp ${T_PRE_LLBL_PAT}/\tJMP___L/go; + s/^\tjmp \*${T_X86_PRE_LLBL_PAT}/\tJMP___SL/go; + s/^\tjmp ${T_X86_PRE_LLBL_PAT}/\tJMP___L/go; s/^(\tjmp .*\n)/$exit_patch$1/g; # here's the fix... - s/^\tJMP___SL/\tjmp \*${T_PRE_LLBL}/go; - s/^\tJMP___L/\tjmp ${T_PRE_LLBL}/go; + s/^\tJMP___SL/\tjmp \*${T_X86_PRE_LLBL}/go; + s/^\tJMP___L/\tjmp ${T_X86_PRE_LLBL}/go; # fix post-PerformGC wrapper (re-)entries ??? @@ -656,14 +1085,29 @@ sub print_doctored { #= if /^\t(jmp|call) .*\%ecx/; } - # final peephole fix + # final peephole fixes s/^\tmovl \%eax,36\(\%ebx\)\n\tjmp \*36\(\%ebx\)\n/\tmovl \%eax,36\(\%ebx\)\n\tjmp \*\%eax\n/; + s/^\tmovl \$_(.*),(\%e[abcd]x)\n\tjmp \*$2/\tjmp _$1/g; + + # Hacks to eliminate some reloads of Hp. Worth about 5% code size. + # We could do much better than this, but at least it catches about + # half of the unnecessary reloads. + # Note that these will stop working if either: + # (i) the offset of Hp from BaseReg changes from 80, or + # (ii) the register assignment of BaseReg changes from %ebx + + s/^\tmovl 80\(\%ebx\),\%e.x\n\tmovl \$(.*),(-?[0-9]*)\(\%e.x\)\n\tmovl 80\(\%ebx\),\%e(.)x/\tmovl 80\(\%ebx\),\%e$3x\n\tmovl \$$1,$2\(\%e$3x\)/g; + + s/^\tmovl 80\(\%ebx\),\%e(.)x\n\tmovl (.*),\%e(.)x\n\tmovl \%e$3x,(-?[0-9]*\(\%e$1x\))\n\tmovl 80\(\%ebx\),\%e$1x/\tmovl 80\(\%ebx\),\%e$1x\n\tmovl $2,\%e$3x\n\tmovl \%e$3x,$4/g; + + s/^\tmovl 80\(\%ebx\),\%edx((\n\t(movl|addl) .*,((-?[0-9]*\(.*)|(\%e[abc]x)))+)\n\tmovl 80\(\%ebx\),\%edx/\tmovl 80\(\%ebx\),\%edx$1/g; + s/^\tmovl 80\(\%ebx\),\%eax((\n\t(movl|addl) .*,((-?[0-9]*\(.*)|(\%e[bcd]x)))+)\n\tmovl 80\(\%ebx\),\%eax/\tmovl 80\(\%ebx\),\%eax$1/g; # -------------------------------------------------------- # that's it -- print it # - die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia + #die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia print OUTASM $_; @@ -739,37 +1183,64 @@ sub rev_tbl { local($before) = ''; local($label) = ''; + local(@imports) = (); # hppa only local(@words) = (); local($after) = ''; local(@lines) = split(/\n/, $tbl); local($i, $extra, $words_to_pad, $j); - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.long\s+/; $i++) { + for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t${T_DOT_WORD}\s+/o; $i++) { $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/ - || $lines[$i] =~ /^\.globl/ - || $lines[$i] =~ /^${T_US}vtbl_\S+:$/; + next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/o + || $lines[$i] =~ /^${T_DOT_GLOBAL}/o + || $lines[$i] =~ /^${T_US}vtbl_\S+${T_POST_LBL}$/o; $before .= $lines[$i] . "\n"; # otherwise... } - for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\s+/; $i++) { - push(@words, $lines[$i]); + if ( $TargetPlatform !~ /^hppa/ ) { + for ( ; $i <= $#lines && $lines[$i] =~ /^\t${T_DOT_WORD}\s+/o; $i++) { + push(@words, $lines[$i]); + } + } else { # hppa weirdness + for ( ; $i <= $#lines && $lines[$i] =~ /^\s+\.(word|IMPORT)/; $i++) { + if ($lines[$i] =~ /^\s+\.IMPORT/) { + push(@imports, $lines[$i]); + } else { + # We don't use HP's ``function pointers'' + # We just use labels in code space, like normal people + $lines[$i] =~ s/P%//; + push(@words, $lines[$i]); + } + } } + # now throw away the first word (entry code): shift(@words) if $discard1; +# Padding removed to reduce code size and improve performance on Pentiums. +# Simon M. 13/4/96 # for 486-cache-friendliness, we want our tables aligned # on 16-byte boundaries (.align 4). Let's pad: - $extra = ($#words + 1) % 4; - $words_to_pad = ($extra == 0) ? 0 : 4 - $extra; - for ($j = 0; $j < $words_to_pad; $j++) { push(@words, "\t\.long 0"); } +# $extra = ($#words + 1) % 4; +# $words_to_pad = ($extra == 0) ? 0 : 4 - $extra; +# for ($j = 0; $j < $words_to_pad; $j++) { push(@words, "\t${T_DOT_WORD} 0"); } for (; $i <= $#lines; $i++) { $after .= $lines[$i] . "\n"; } - $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after; + # Alphas:If we have anonymous text (not part of a procedure), the + # linker may complain about missing exception information. Bleh. + if ( $TargetPlatform =~ /^alpha-/ && $label =~ /^([A-Za-z0-9_]+):$/) { + $before = "\t.ent $1\n" . $before; + $after .= "\t.end $1\n"; + } + + $tbl = $before + . (($TargetPlatform !~ /^hppa/) ? '' : join("\n", @imports) . "\n") + . join("\n", (reverse @words)) . "\n" + . $label . $after; # print STDERR "before=$before\n"; # print STDERR "label=$label\n"; @@ -781,7 +1252,7 @@ sub rev_tbl { \end{code} \begin{code} -sub mini_mangle_asm { +sub mini_mangle_asm_i386 { local($in_asmf, $out_asmf) = @_; &init_TARGET_STUFF(); @@ -804,6 +1275,33 @@ sub mini_mangle_asm { close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); } +\end{code} + +The HP is a major nuisance. The threaded code mangler moved info +tables from data space to code space, but unthreaded code in the RTS +still has references to info tables in data space. Since the HP +linker is very precise about where symbols live, we need to patch the +references in the unthreaded RTS as well. + +\begin{code} +sub mini_mangle_asm_hppa { + local($in_asmf, $out_asmf) = @_; + + open(INASM, "< $in_asmf") + || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); + open(OUTASM,"> $out_asmf") + || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); + + while (<INASM>) { + s/_info,DATA/_info,CODE/; # Move _info references to code space + s/P%_PR/_PR/; + print OUTASM; + } + + # finished: + close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); + close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); +} # make "require"r happy... 1; diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl new file mode 100644 index 0000000000..5f0fe311b1 --- /dev/null +++ b/ghc/driver/ghc-iface.lprl @@ -0,0 +1,271 @@ +%************************************************************************ +%* * +\section[Driver-iface-thing]{Interface-file handling} +%* * +%************************************************************************ + +\begin{code} +sub postprocessHiFile { + local($hsc_hi, # The iface info produced by hsc. + $hifile_target, # The name both of the .hi file we + # already have and which we *might* + # replace. + $going_interactive) = @_; + + local($new_hi) = "$Tmp_prefix.hi-new"; + +# print STDERR `$Cat $hsc_hi`; + + &constructNewHiFile($hsc_hi, $hifile_target, $new_hi); + + # run diff if they asked for it + if ($HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target) { + &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0", + "Diff'ing old and new .$HiSuffix files"); # NB: to stderr + } + + # if we produced an interface file "no matter what", + # print what we got on stderr (ToDo: honor -ohi flag) + if ( $HiOnStdout ) { + print STDERR `$Cat $new_hi`; + } else { + &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )", + "Replace .$HiSuffix file, if changed"); + } +} +\end{code} + +\begin{code} +sub constructNewHiFile { + local($hsc_hi, # The iface info produced by hsc. + $hifile_target, # Pre-existing .hi filename (if it exists) + $new_hi) = @_; # Filename for new one + + &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1; + &readHiFile('new',$hsc_hi) unless $HiHasBeenRead{'new'} == 1; + + open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n"); + + local($new_module_version) = &calcNewModuleVersion(); + print NEWHI "interface ", $ModuleName{'new'}, " $new_module_version\n"; + + print NEWHI "__usages__\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq ''; + + local(@version_keys) = sort (keys %Version); + local($num_ver_things) = 0; + foreach $v (@version_keys) { + next unless $v =~ /^new:(.*$)/; + last if $num_ver_things >= 1; + $num_ver_things++; + } + + print NEWHI "__versions__\n" unless $num_ver_things < 1; + foreach $v (@version_keys) { + next unless $v =~ /^new:(.*$)/; + $v = $1; + + &printNewItemVersion($v, $new_module_version), "\n"; + } + + print NEWHI "__exports__\n"; + print NEWHI $Stuff{'new:exports'}; + + if ( $Stuff{'new:instance_modules'} ) { + print NEWHI "__instance_modules__\n"; + print NEWHI $Stuff{'new:instance_modules'}; + } + + if ( $Stuff{'new:fixities'} ) { + print NEWHI "__fixities__\n"; + print NEWHI $Stuff{'new:fixities'}; + } + + if ( $Stuff{'new:declarations'} ) { + print NEWHI "__declarations__\n"; + print NEWHI $Stuff{'new:declarations'}; + } + + if ( $Stuff{'new:instances'} ) { + print NEWHI "__instances__\n"; + print NEWHI $Stuff{'new:instances'}; + } + + if ( $Stuff{'new:pragmas'} ) { + print NEWHI "__pragmas__\n"; + print NEWHI $Stuff{'new:pragmas'}; + } + + close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n"); +} +\end{code} + +\begin{code} +%Version = (); +%Decl = (); # details about individual definitions +%Stuff = (); # where we glom things together +%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't +%HiHasBeenRead = ('old', 0, 'new', 0); +%ModuleVersion = ('old', 0, 'new', 0); + +sub readHiFile { + local($mod, # module to read; can be special tag 'old' + # (old .hi file for module being compiled) or + # 'new' (new proto-.hi file for...) + $hifile) = @_; # actual file to read + + # info about the old version of this module's interface + $HiExists{$mod} = -1; # 1 <=> definitely exists; 0 <=> doesn't + $HiHasBeenRead{$mod} = 0; + $ModuleVersion{$mod} = 0; + $Stuff{"$mod:usages"} = ''; # stuff glommed together + $Stuff{"$mod:exports"} = ''; + $Stuff{"$mod:instance_modules"} = ''; + $Stuff{"$mod:instances"} = ''; + $Stuff{"$mod:fixities"} = ''; + $Stuff{"$mod:declarations"} = ''; + $Stuff{"$mod:pragmas"} = ''; + + if (! -f $hifile) { # no pre-existing .hi file + $HiExists{$mod} = 0; + return(); + } + + open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n"); + $HiExists{$mod} = 1; + local($now_in) = ''; + hi_line: while (<HIFILE>) { + next if /^ *$/; # blank line + + # avoid pre-1.3 interfaces +#print STDERR "now_in:$now_in:$_"; + if ( /\{-# GHC_PRAGMA INTERFACE VERSION . #-\}/ ) { + $HiExists{$mod} = 0; + last hi_line; + } + + if ( /^interface ([A-Z]\S*) (\d+)/ ) { + $ModuleName{$mod} = $1; # not sure this is used much... + $ModuleVersion{$mod} = $2; + + } elsif ( /^interface ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version + $ModuleName{'new'} = $1; + + } elsif ( /^__([a-z]+)__$/ ) { + $now_in = $1; + + } elsif ( $now_in eq 'usages' && /^(\S+)\s+(\d+)\s+:: (.*)/ ) { + $Stuff{"$mod:usages"} .= $_; # save the whole thing + + } elsif ( $now_in eq 'versions' && /^(\S+) (\d+)/ ) { + local($item) = $1; + local($n) = $2; +#print STDERR "version read:item=$item, n=$n, line=$_"; + $Version{"$mod:$item"} = $n; + + } elsif ( $now_in eq 'versions' && /^(\S+)/ && $mod eq 'new') { # doesn't have versions + local($item) = $1; +#print STDERR "new version read:item=$item, line=$_"; + $Version{"$mod:$item"} = 'y'; # stub value... + + } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities|pragmas)$/ ) { + $Stuff{"$mod:$1"} .= $_; # just save it up + + } elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed... + $Stuff{"$mod:declarations"} .= $_; # just save it up + + if ( /^[A-Z][A-Za-z0-9_']*\.(\S+)\s+::\s+/ ) { + $Decl{"$mod:$1"} = $_; + + } elsif ( /^type\s+[A-Z][A-Za-z0-9_']*\.(\S+)/ ) { + $Decl{"$mod:$1"} = $_; + + } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) { + $Decl{"$mod:$3"} = $_; + + } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+.*where\s+\{.*\};/ ) { + $Decl{"$mod:$2"} = $_; # must be wary of => bit matching after "where"... + } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) { + $Decl{"$mod:$2"} = $_; + + } else { # oh, well... + print STDERR "$Pgm: decl line didn't match?\n$_"; + } + + } else { + print STDERR "$Pgm:junk old iface line?:section:$now_in:$_"; + } + } + +# foreach $i ( sort (keys %Decl)) { +# print STDERR "$i: ",$Decl{$i}, "\n"; +# } + + close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n"); + $HiHasBeenRead{$mod} = 1; +} +\end{code} + +\begin{code} +sub calcNewModuleVersion { + + return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0; + # could use "time()" as initial version; if a module existed, then was deleted, + # then comes back, we don't want the resurrected one to have an + # lower version number than the original (in case there are any + # lingering references to the original in other .hi files). + + local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two + local($changed_version) = $unchanged_version + 1; + + return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'}; + + foreach $t ( 'exports', 'instance_modules', 'instances', 'fixities', 'declarations', 'pragmas' ) { + return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"}; + } + + return($unchanged_version); +} + +sub mv_change { + local($mv, $str) = @_; + + print STDERR "$Pgm: module version changed to $mv; reason: $str\n"; + return($mv); +} + +sub printNewItemVersion { + local($item, $mod_version) = @_; + + if (! defined($Decl{"new:$item"}) ) { + print STDERR "$item: no decl?! (nothing into __versions__)\n"; + return; + } + + local($idecl) = $Decl{"new:$item"}; + + if (! defined($Decl{"old:$item"})) { + print STDERR "new: $item\n"; + print NEWHI "$item $mod_version\n"; + } elsif ($idecl ne $Decl{"old:$item"}) { + print STDERR "changed: $item\n"; + print NEWHI "$item $mod_version\n"; + } elsif (! defined($Version{"old:$item"}) ) { + print STDERR "$item: no old version?!\n" + } else { + print NEWHI "$item ", $Version{"old:$item"}, "\n"; + } + return; +} +\end{code} + +\begin{code} +sub findHiChanges { + local($hsc_hi, # The iface info produced by hsc. + $hifile_target) = @_; # Pre-existing .hi filename (if it exists) +} +\end{code} + +\begin{code} +# make "require"r happy... +1; +\end{code} diff --git a/ghc/driver/ghc-recomp.lprl b/ghc/driver/ghc-recomp.lprl new file mode 100644 index 0000000000..3414605e8d --- /dev/null +++ b/ghc/driver/ghc-recomp.lprl @@ -0,0 +1,135 @@ +%************************************************************************ +%* * +\section[Driver-recomp-chking]{Recompilation checker} +%* * +%************************************************************************ + +\begin{code} +sub runRecompChkr { + local($ifile, # originating input file + $ifile_hs, # post-unlit, post-cpp, etc., input file + $ifile_root, # input filename minus suffix + $ofile_target,# the output file that we ultimately hope to produce + $hifile_target# the .hi file ... (ditto) + ) = @_; + + ($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"; + return(1); + } + + ($o_dev,$o_ino,$o_mode,$o_nlink,$o_uid,$o_gid,$o_rdev,$o_size, + $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"; + return(1); + } + + ($hi_dev,$hi_ino,$hi_mode,$hi_nlink,$hi_uid,$hi_gid,$hi_rdev,$hi_size, + $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 ($i_mtime > $o_mtime)\n"; + return(1); + } + + # OK, let's see what we used last time; if none of it has + # changed, then we don't need to continue with this compilation. + require('ghc-iface.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl (recomp)!\n"); + &tidy_up_and_die(1,"$Pgm:recomp:why has $hifile_target already been read?\n") + if $HiHasBeenRead{'old'} == 1; + + &readHiFile('old',$hifile_target); + %ModUsed = (); + %Used = (); + + foreach $ul ( split(/;\n/, $Stuff{'old:usages'}) ) { + + $ul =~ /^(\S+)\s+(\d+)\s+:: (.*)/ || die "$Pgm: bad old usages line!\n"; + local($mod) = $1; + local($modver) = $2; + local(@thing) = split(/\s+/, $3); + + $ModUsed{$mod} = $modver; + + local($key, $n); + while ( $#thing >= 0 ) { + $key = "$mod:" . $thing[0]; + $n = $thing[1]; + $Used{$key} = $n; + shift @thing; shift @thing; # toss two + } + } + + # see if we can avoid recompilation just by peering at the + # module-version numbers: + + &makeHiMap() unless $HiMapDone; + + local($used_modules_have_changed) = 0; + used_mod: foreach $um ( keys %ModUsed ) { + if ( ! defined($HiMap{$um}) ) { + print STDERR "$Pgm:recompile:interface for used module $um no longer exists\n"; + foreach $hm ( keys %HiMap ) { + print STDERR "$hm ==> ", $HiMap{$hm}, "\n"; + } + return 1; + } else { + if ( $HiHasBeenRead{$um} ) { + print STDERR "$Pgm:very strange that $um.hi has already been read?!?\n" + } else { + &readHiFile($um, $HiMap{$um}); + } + } + if ( $ModUsed{$um} != $ModuleVersion{$um} ) { + print STDERR "used module version: $um: was: ",$ModUsed{$um}, "; is ", $ModuleVersion{$um}, "\n"; + $used_modules_have_changed = 1; + last used_mod; # no point continuing... + } + } + return 0 if ! $used_modules_have_changed; + + # well, some module version has changed, but maybe no + # entity of interest has... +print STDERR "considering used entities...\n"; + local($used_entities_have_changed) = 0; + + used_entity: foreach $ue ( keys %Used ) { + $ue =~ /([A-Z][A-Za-z0-9_']*):(.+)/; + local($ue_m) = $1; + local($ue_n) = $2; + + die "$Pgm:interface for used-entity module $ue_m doesn't exist\n" + if ! defined($HiMap{$ue_m}); + + &readHiFile($ue_m, $HiMap{$ue_m}) unless $HiHasBeenRead{$ue_m}; + # we might not have read it before... + + if ( !defined($Version{$ue}) ) { + print STDERR "No version info for $ue?!\n"; + + } elsif ( $Used{$ue} != $Version{$ue} ) { + print STDERR "$Pgm:recompile: used entity changed: $ue: was version ",$Used{$ue},"; is ", $Version{$ue}, "\n"; + $used_entities_have_changed = 1; + last used_entity; # no point continuing... + } + } + return 0 if ! $used_entities_have_changed; + + print STDERR "ifile $ifile:\t$i_mtime\n"; + print STDERR "ofile $ofile_target:\t$o_mtime\n"; + print STDERR "hifile $hifile_target:\t$hi_mtime\n"; + + return(1); # OK, *recompile* +} +\end{code} + +\begin{code} +# make "require"r happy... +1; +\end{code} diff --git a/ghc/driver/ghc-split.lprl b/ghc/driver/ghc-split.lprl index 00c116e314..3a4dadb97b 100644 --- a/ghc/driver/ghc-split.lprl +++ b/ghc/driver/ghc-split.lprl @@ -9,7 +9,7 @@ sub inject_split_markers { local($hc_file) = @_; unlink("$Tmp_prefix.unmkd"); - local($to_do) = "cp $hc_file $Tmp_prefix.unmkd"; + local($to_do) = "$Cp $hc_file $Tmp_prefix.unmkd"; &run_something($to_do, 'Prepare to number split markers'); open(TMPI, "< $Tmp_prefix.unmkd") || &tidy_up_and_die(1,"$Pgm: failed to open `$Tmp_prefix.unmkd' (to read)\n"); @@ -191,8 +191,8 @@ sub process_asm_block_sparc { if ( $OptimiseC ) { $str =~ s/_?__stg_split_marker.*:\n//; } else { - $str =~ s/(\.text\n\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/\1/; - $str =~ s/(\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/\1/; + $str =~ s/(\.text\n\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/$1/; + $str =~ s/(\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/$1/; } # make sure the *.hc filename gets saved; not just ghc*.c (temp name) @@ -226,10 +226,10 @@ sub process_asm_block_sparc { sub process_asm_block_m68k { local($str) = @_; - # strip the marker (ToDo: something special for unregisterized???) + # strip the marker - $str =~ s/(\.text\n\t\.even\n)\t\.globl\s+.*_?__stg_split_marker.*\n/\1/; - $str =~ s/(\t\.even\n)\t\.globl\s+.*_?__stg_split_marker.*\n/\1/; + $str =~ s/(\.text\n\t\.even\n)\t\.globl\s+.*_?__stg_split_marker.*\n/$1/; + $str =~ s/(\t\.even\n)\t\.globl\s+.*_?__stg_split_marker.*\n/$1/; # it seems prudent to stick on one of these: $str = "\.text\n\t.even\n" . $str; @@ -266,7 +266,7 @@ sub process_asm_block_alpha { if ( $OptimiseC ) { $str =~ s/_?__stg_split_marker.*:\n//; } else { - $str =~ s/(\t\.align .\n)\t\.globl\s+.*_?__stg_split_marker.*\n\t\.ent.*\n/\1/; + $str =~ s/(\t\.align .\n)\t\.globl\s+.*_?__stg_split_marker.*\n\t\.ent.*\n/$1/; } # remove/record any literal constants defined here @@ -292,7 +292,7 @@ sub process_asm_block_alpha { # Slide the dummy direct return code into the vtbl .ent/.end block, # to keep the label fixed if it's the last thing in a module, and # to avoid having any anonymous text that the linker will complain about - $str =~ s/(\t\.end [A-Za-z0-9_]+)\n\t# nop/\tnop\n\1/g; + $str =~ s/(\t\.end [A-Za-z0-9_]+)\n\t# nop/\tnop\n$1/g; print STDERR "### STRIPPED BLOCK (alpha):\n$str" if $Dump_asm_splitting_info; @@ -302,10 +302,10 @@ sub process_asm_block_alpha { sub process_asm_block_iX86 { local($str) = @_; - # strip the marker (ToDo: something special for unregisterized???) + # strip the marker - $str =~ s/(\.text\n\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/\1/; - $str =~ s/(\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/\1/; + $str =~ s/(\.text\n\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/$1/; + $str =~ s/(\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/$1/; # it seems prudent to stick on one of these: $str = "\.text\n\t.align 4\n" . $str; @@ -396,7 +396,7 @@ sub process_asm_block_mips { if ( $OptimiseC ) { $str =~ s/_?__stg_split_marker.*:\n//; } else { - $str =~ s/(\t\.align .\n)\t\.globl\s+.*_?__stg_split_marker.*\n\t\.ent.*\n/\1/; + $str =~ s/(\t\.align .\n)\t\.globl\s+.*_?__stg_split_marker.*\n\t\.ent.*\n/$1/; } # remove/record any literal constants defined here @@ -422,7 +422,7 @@ sub process_asm_block_mips { # Slide the dummy direct return code into the vtbl .ent/.end block, # to keep the label fixed if it's the last thing in a module, and # to avoid having any anonymous text that the linker will complain about - $str =~ s/(\t\.end [A-Za-z0-9_]+)\n\t# nop/\tnop\n\1/g; + $str =~ s/(\t\.end [A-Za-z0-9_]+)\n\t# nop/\tnop\n$1/g; $str .= $UNDEFINED_FUNS; # pin on gratuitiously-large amount of info diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 8ccef55cfc..09f1bef6e4 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -37,7 +37,7 @@ possible phases of a compilation: For each input file, the phase to START with is determined by the file's suffix: - .lhs literate Haskell: lit2pgm - - .hs illiterate Haskell: hsp + - .hs illiterate Haskell: hsc - .hc C from the Haskell compiler: gcc - .c C not from the Haskell compiler: gcc - .s assembly language: as @@ -56,7 +56,7 @@ option: Other commonly-used options are: - -O An `optimising' package of options, to produce faster code + -O An `optimising' package of compiler flags, for faster code -prof Compile for cost-centre profiling (add -auto for automagic cost-centres on top-level functions) @@ -108,17 +108,19 @@ if (! $ENV{'GLASGOW_HASKELL_ROOT'}) { # good -- death to environment variables $TopPwd = '$(TOP_PWD)'; $InstLibDirGhc = '$(INSTLIBDIR_GHC)'; $InstDataDirGhc = '$(INSTDATADIR_GHC)'; +# $InstSysLibDir = '$(INSTLIBDIR_HSLIBS)'; ToDo ToDo + $InstSysLibDir = '$(TOP_PWD)/hslibs'; } else { $TopPwd = $ENV{'GLASGOW_HASKELL_ROOT'}; - if ( '$(INSTLIBDIR_GHC)' =~ /^\/(local\/fp|usr\/local)(\/.*)/ ) { - $InstLibDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $2; + 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"; exit(1); } - if ( '$(INSTDATADIR_GHC)' =~ /\/(local\/fp|usr\/local)(\/.*)/ ) { + 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"; @@ -128,8 +130,6 @@ if (! $ENV{'GLASGOW_HASKELL_ROOT'}) { # good -- death to environment variables $Status = 0; # just used for exit() status $Verbose = ''; -$CoreLint = ''; -$Time = ''; # ToDo: mkworld-ize the timing command # set up signal handler sub quit_upon_signal { &tidy_up_and_die(1, ''); } @@ -138,7 +138,7 @@ $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" +@INC = ( ( $(INSTALLING) ) ? $InstLibDirGhc : "$TopPwd/$(CURRENT_DIR)" ); if ( $ENV{'TMPDIR'} ) { # where to make tmp file names @@ -154,7 +154,12 @@ $Unlit = ( $(INSTALLING) ) ? "$InstLibDirGhc/unlit" : "$TopPwd/$(CURRENT_DIR)/$(GHC_UNLIT)"; @Unlit_flags = (); -$Cat = "cat"; +$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" @@ -162,10 +167,6 @@ $HsCpp = # but this is re-set to "cat" (after options) if -cpp not seen @HsCpp_flags = (); $genSPECS_flag = ''; # See ../utils/hscpp/hscpp.prl -$HsP = ( $(INSTALLING) ) ? "$InstLibDirGhc/hsp" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_HSP)"; -@HsP_flags = (); - $HsC = ( $(INSTALLING) ) ? "$InstLibDirGhc/hsc" : "$TopPwd/$(CURRENT_DIR)/$(GHC_HSC)"; @@ -177,10 +178,11 @@ $SysMan = ( $(INSTALLING) ) ? "$InstLibDirGhc/SysMan" # terrible things to cache behavior. $Specific_heap_size = 6 * 1000 * 1000; $Specific_stk_size = 1000 * 1000; -$Scale_sizes_by = 1.0; -$RTS_style = $(GHC_RTS_STYLE); -@HsC_rts_flags = (); +$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} @@ -189,9 +191,10 @@ 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 +$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,'' @@ -202,41 +205,31 @@ $Oopt_UnfoldingUseThreshold = '-fsimpl-uf-use-threshold3'; $Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations4'; $Oopt_PedanticBottoms = '-fpedantic-bottoms'; # ON by default $Oopt_MonadEtaExpansion = ''; -#OLD:$Oopt_LambdaLift = ''; -$Oopt_AddAutoSccs = ''; $Oopt_FinalStgProfilingMassage = ''; $Oopt_StgStats = ''; $Oopt_SpecialiseUnboxed = ''; $Oopt_DoSpecialise = '-fspecialise'; $Oopt_FoldrBuild = 1; # On by default! -$Oopt_FB_Support = '-fdo-new-occur-anal -fdo-arity-expand'; +$Oopt_FB_Support = '-fdo-arity-expand'; #$Oopt_FoldrBuildWW = 0; # Off by default $Oopt_FoldrBuildInline = '-fdo-inline-foldr-build'; \end{code} Things to do with C compilers/etc: \begin{code} -$CcUnregd = '$(GHC_DEBUG_HILEV_ASM)'; # our high-level assembler (non-optimising) -$CcRegd = '$(GHC_OPT_HILEV_ASM)'; # our high-level assembler (optimising) -$GccAvailable = $(GHC_GCC_IS_AVAILABLE); # whether GCC avail or not for optimising - +$CcRegd = 'gcc'; @CcBoth_flags = ('-S'); # flags for *any* C compilation @CcInjects = (); -# non-registerizing flags: those for all files, those only for .c files; those only for .hc files -@CcUnregd_flags = ( $GccAvailable ) ? ('-ansi', '-pedantic') : (); -@CcUnregd_flags_c = (); -@CcUnregd_flags_hc= (); - -# ditto; but for registerizing (we must have GCC for this) +# 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 = (); -$As = ''; # assembler is normally the same pgm as used for C compilation +$As = ''; # "assembler" is normally GCC @As_flags = (); -$Lnkr = ''; # linker is normally the same pgm as used for C compilation +$Lnkr = ''; # "linker" is normally GCC @Ld_flags = (); # 'nm' is used for consistency checking (ToDo: mk-world-ify) @@ -283,7 +276,7 @@ $BuildTag = ''; # default is sequential build w/ Appel-style GC %BuildDescr = ('', 'normal sequential', '_p', 'profiling', '_t', 'ticky-ticky profiling', - '_u', 'unregisterized (using portable C only)', +#OLD: '_u', 'unregisterized (using portable C only)', '_mc', 'concurrent', '_mr', 'profiled concurrent', '_mt', 'ticky concurrent', @@ -341,12 +334,15 @@ $BuildTag = ''; # default is sequential build w/ Appel-style GC '_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\');', - # unregisterized (ToDo????) - '_u', '', +#OLD: # unregisterized (ToDo????) +# '_u', '', # concurrent '_mc', '$StkChkByPageFaultOK = 0; @@ -374,7 +370,8 @@ $BuildTag = ''; # default is sequential build w/ Appel-style GC # GranSim '_mg', '$StkChkByPageFaultOK = 0; - push(@HsC_flags, \'-fconcurrent\'); + push(@HsC_flags, \'-fconcurrent\', \'-fgransim\'); + push(@HsCpp_flags,\'-D__GRANSIM__\', \'-DGRAN\'); push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DGRAN\');', '_2s', 'push (@CcBoth_flags, \'-DGC2s\');', @@ -409,17 +406,17 @@ require special handling. @SysImport_dir = ( $(INSTALLING) ) ? ( "$InstDataDirGhc/imports" ) : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/prelude" - ); + , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/required" ); -$ghc_version_info = $(PROJECTVERSION) * 100; -$haskell1_version = 2; # i.e., Haskell 1.2 -@Cpp_define = (); +$GhcVersionInfo = 201; # ToDo: int ($(PROJECTVERSION) * 100); +$Haskell1Version = 3; # i.e., Haskell 1.3 +@Cpp_define = (); @UserLibrary_dir= (); #-L things;... @UserLibrary = (); #-l things asked for by the user @SysLibrary_dir = ( ( $(INSTALLING) ) #-syslib things supplied by the system - ? "$InstLibDirGhc" + ? $InstLibDirGhc : ("$TopPwd/$(CURRENT_DIR)/$(GHC_RUNTIMESRC)", "$TopPwd/$(CURRENT_DIR)/$(GHC_RUNTIMESRC)/gmp", "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)") @@ -440,35 +437,28 @@ start with. Linking is weird and kept track of separately. Here are the initial defaults applied to all files: \begin{code} -$Do_lit2pgm = 1; -$Do_hscpp = 1; # but we run 'cat' by default (see after arg check) $Cpp_flag_set = 0; # (hack) $Only_preprocess_C = 0; # pretty hackish -$ProduceHi = 1; # but beware magical value "2"! (hack) $PostprocessCcOutput = 0; -$HiDiff_flag= 0; # native code-gen or via C? $HaveNativeCodeGen = $(GHC_WITH_NATIVE_CODEGEN); -$ProduceS = ''; -if ($HaveNativeCodeGen) { - if ($TargetPlatform =~ /^(alpha|sparc)-/) { - $ProduceS = $TargetPlatform; - } -} -$ProduceC = ($ProduceS) ? 0 : 1; +$HscOut = '-C='; # '-C=' ==> .hc output; '-S=' ==> .s output; '-N=' ==> neither +$HscOut = '-S=' + if $HaveNativeCodeGen && $TargetPlatform =~ /^(alpha|sparc|i386)-/; +$ProduceHi = '-hifile='; +$HiOnStdout = 0; +$HiDiff_flag = 0; $CollectingGCstats = 0; $CollectGhcTimings = 0; -$RegisteriseC = ''; # set to 'o', if using optimised C code (only if avail) - # or if generating equiv asm code $DEBUGging = ''; # -DDEBUG and all that it entails (um... not really) $PROFing = ''; # set to p or e if profiling $PROFgroup = ''; # set to group if an explicit -Ggroup specified $PROFauto = ''; # set to relevant hsc flag if -auto or -auto-all $PROFcaf = ''; # set to relevant hsc flag if -caf-all -#UNUSED:$PROFdict = ''; # set to relevant hsc flag if -dict-all $PROFignore_scc = ''; # set to relevant parser flag if explicit sccs ignored +$UNPROFscc_auto = ''; # set to relevant hsc flag if forcing auto sccs without profiling $TICKYing = ''; # set to t if compiling for ticky-ticky profiling $PARing = ''; # set to p if compiling for PAR $CONCURing = ''; # set to c if compiling for CONCURRENT @@ -479,23 +469,22 @@ $Specific_output_file = ''; # set by -o <file>; "-" for stdout $Specific_hi_file = ''; # set by -ohi <file>; "-" for stdout $Specific_dump_file = ''; # set by -odump <file>; "-" for stdout $Using_dump_file = 0; -$Osuffix = '.o'; -$HiSuffix = '.hi'; -$Do_hsp = 2; # 1 for "old" parser; 2 for "new" parser (in hsc) -$Do_hsc = 1; +$Osuffix = ''; # default: use the normal suffix for that kind of output +$HiSuffix = 'hi'; +$SysHiSuffix= 'hi'; +$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; $Do_lnkr = 1; $Keep_hc_file_too = 0; $Keep_s_file_too = 0; -$CompilingPrelude = 0; +$UseGhcInternals = 0; # if 1, may use GHC* modules $SplitObjFiles = 0; $NoOfSplitFiles = 0; $Dump_parser_output = 0; $Dump_raw_asm = 0; -$Dump_asm_insn_counts = 0; -$Dump_asm_globals_info = 0; $Dump_asm_splitting_info = 0; +$NoImplicitPrelude = 0; # and the list of files @Input_file = (); @@ -516,16 +505,16 @@ $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 = 29; +$HsC_major_version = 30; $HsC_minor_version = 0; -$Cc_major_version = 33; +$Cc_major_version = 35; $Cc_minor_version = 0; # options: these must always agree $HsC_consist_options = ''; # we record, in this order: # Build tag; debugging? $Cc_consist_options = ''; # we record, in this order: - # Build tag; debugging? registerised? + # Build tag; debugging? \end{code} %************************************************************************ @@ -556,11 +545,10 @@ if (grep(/^-user-prelude$/, @ARGV)) { @ARGV); unshift(@ARGV, - '-prelude', + '-fcompiling-ghc-internals=???', # ToDo!!!! '-O', '-fshow-pragma-name-errs', '-fshow-import-specs', - '-fomit-reexported-instances', '-fglasgow-exts', '-genSPECS', '-DUSE_FOLDR_BUILD', @@ -580,25 +568,25 @@ arg: while($_ = $ARGV[0]) { /^-v$/ && do { $Verbose = '-v'; $Time = 'time'; next arg; }; #---------- what phases are to be run ---------------------------------- + /^-short$/ && do { $Do_recomp_chkr = 1; next arg; }; + /^-cpp$/ && do { $Cpp_flag_set = 1; next arg; }; # change the global default: # we won't run cat; we'll run the real thing - /^-C$/ && do { $Do_cc = 0; $Do_as = 0; $Do_lnkr = 0; - $ProduceC = 1; $ProduceS = ''; + /^-C$/ && do { $Do_cc = 0; $Do_as = 0; $Do_lnkr = 0; $HscOut = '-C='; next arg; }; # stop after generating C - /^-noC$/ && do { $ProduceC = 0; $ProduceS = ''; $ProduceHi = 0; + /^-noC$/ && do { $HscOut = '-N='; $ProduceHi = '-nohifile='; $Do_cc = 0; $Do_as = 0; $Do_lnkr = 0; next arg; }; # leave out actual C generation (debugging) [also turns off interface gen] - /^-hi$/ && do { $ProduceHi = 2; next arg; }; + /^-hi$/ && do { $HiOnStdout = 1; $ProduceHi = '-hifile='; next arg; }; # _do_ generate an interface; usually used as: -noC -hi - # NB: magic value "2" for $ProduceHi (hack) - /^-nohi$/ && do { $ProduceHi = 0; next arg; }; + /^-nohi$/ && do { $ProduceHi = '-nohifile='; next arg; }; # don't generate an interface (even if generating C) /^-hi-diffs$/ && do { $HiDiff_flag = 1; next arg; }; @@ -620,24 +608,6 @@ arg: while($_ = $ARGV[0]) { /^-no-link-chk$/ && do { $LinkChk = 0; next arg; }; # don't do consistency-checking after a link - # generate code for a different target architecture; e.g., m68k - # ToDo: de-Glasgow-ize & probably more... -# OLD: -# /^-target$/ && do { $TargetPlatform = &grab_arg_arg('-target', ''); -# if ($TargetPlatform ne $HostPlatform) { -# if ( $TargetPlatform =~ /^m68k-/ ) { -# $CcUnregd = $CcRegd = 'gcc-m68k'; -# } else { -# print STDERR "$Pgm: Can't handle -target $TargetPlatform\n"; -# $Status++; -# } -# } -# next arg; }; - - /^-unregisteri[sz]ed$/ && do { $RegisteriseC = 'no'; - $ProduceC = 1; $ProduceS = ''; # via C, definitely - next arg; }; - /^-tmpdir$/ && do { $Tmp_prefix = &grab_arg_arg('-tmpdir', ''); $Tmp_prefix = "$Tmp_prefix/ghc$$"; $ENV{'TMPDIR'} = $Tmp_prefix; # for those who use it... @@ -650,6 +620,13 @@ arg: while($_ = $ARGV[0]) { # "-o -" sends it to stdout # if <file> has a directory component, that dir must already exist + /^-odir$/ && do { $Specific_output_dir = &grab_arg_arg('-odir', ''); + if (! -d $Specific_output_dir) { + print STDERR "$Pgm: -odir: no such directory: $Specific_output_dir\n"; + $Status++; + } + next arg; }; + /^-o$/ && do { $Specific_output_file = &grab_arg_arg('-o', ''); if ($Specific_output_file ne '-' && $Specific_output_file =~ /(.*)\/[^\/]*$/) { @@ -661,6 +638,13 @@ arg: while($_ = $ARGV[0]) { } next arg; }; + /^-osuf$/ && do { $Osuffix = &grab_arg_arg('-osuf', ''); + if ($Osuffix =~ /\./ ) { + print STDERR "$Pgm: -osuf suffix shouldn't contain a .\n"; + $Status++; + } + next arg; }; + # -ohi <file>; send the interface to <file>; "-ohi -" to send to stdout /^-ohi$/ && do { $Specific_hi_file = &grab_arg_arg('-ohi', ''); if ($Specific_hi_file ne '-' @@ -673,6 +657,20 @@ arg: while($_ = $ARGV[0]) { } next arg; }; + /^-hisuf$/ && do { $HiSuffix = &grab_arg_arg('-hisuf', ''); + if ($HiSuffix =~ /\./ ) { + print STDERR "$Pgm: -hisuf suffix shouldn't contain a .\n"; + $Status++; + } + next arg; }; + /^-hisuf-prelude$/ && do { # as esoteric as they come... + $SysHiSuffix = &grab_arg_arg('-hisuf-prelude', ''); + if ($SysHiSuffix =~ /\./ ) { + print STDERR "$Pgm: -hisuf-prelude suffix shouldn't contain a .\n"; + $Status++; + } + next arg; }; + /^-odump$/ && do { $Specific_dump_file = &grab_arg_arg('-odump', ''); if ($Specific_dump_file =~ /(.*)\/[^\/]*$/) { local($dir_part) = $1; @@ -683,23 +681,6 @@ arg: while($_ = $ARGV[0]) { } next arg; }; - /^-odir$/ && do { $Specific_output_dir = &grab_arg_arg('-odir', ''); - if (! -d $Specific_output_dir) { - print STDERR "$Pgm: -odir: no such directory: $Specific_output_dir\n"; - $Status++; - } - next arg; }; - - /^-osuf$/ && do { $Osuffix = &grab_arg_arg('-osuf', ''); next arg; }; - /^-hisuf$/ && do { $HiSuffix = &grab_arg_arg('-hisuf', ''); - push(@HsP_flags, "-h$HiSuffix"); - next arg; }; - - /^-hisuf-prelude$/ && do { # as esoteric as they come... - local($suffix) = &grab_arg_arg('-hisuf-prelude', ''); - push(@HsP_flags, "-g$suffix"); - next arg; }; - #-------------- scc & Profiling Stuff ---------------------------------- /^-prof$/ && do { $PROFing = 'p'; next arg; }; # profiling -- details later! @@ -717,19 +698,22 @@ arg: while($_ = $ARGV[0]) { $PROFcaf = '-fauto-sccs-on-individual-cafs'; next arg; }; -# UNUSED: -# /^-dict-all/ && do { # generate individual SCC annotations on dictionaries -# $PROFdict = '-fauto-sccs-on-individual-dicts'; -# next arg; }; - /^-ignore-scc$/ && do { # forces ignore of scc annotations even if profiling $PROFignore_scc = '-W'; next arg; }; - /^-G(.*)$/ && do { push(@HsC_flags, $_); # set group for cost centres + /^-G(.*)$/ && do { push(@HsC_flags, "-G=$1"); # set group for cost centres 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 + $UNPROFscc_auto = ( /-all/ ) + ? '-fauto-sccs-on-all-toplevs' + : '-fauto-sccs-on-exported-toplevs'; + next arg; }; + #--------- ticky/concurrent/parallel ----------------------------------- # we sort out the details a bit later on @@ -816,12 +800,12 @@ arg: while($_ = $ARGV[0]) { /^-syslib(.*)/ && do { local($syslib) = &grab_arg_arg('-syslib',$1); print STDERR "$Pgm: no such system library (-syslib): $syslib\n", - $Status++ unless $syslib =~ /^(hbc|ghc|contrib)$/; + $Status++ unless $syslib =~ /^(hbc|ghc|posix|contrib)$/; unshift(@SysImport_dir, $(INSTALLING) - ? "$InstDataDirGhc/imports/$syslib" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/$syslib"); + ? "$InstSysLibDir/$syslib/imports" + : "$TopPwd/hslibs/$syslib/src"); unshift(@SysLibrary, ('-lHS' . $syslib )); @@ -836,10 +820,8 @@ arg: while($_ = $ARGV[0]) { # these change what executable is run for each phase: /^-pgmL(.*)$/ && do { $Unlit = $1; next arg; }; /^-pgmP(.*)$/ && do { $HsCpp = $1; next arg; }; - /^-pgmp(.*)$/ && do { $HsP = $1; next arg; }; /^-pgmC(.*)$/ && do { $HsC = $1; next arg; }; - /^-pgmcO(.*)$/ && do { $CcRegd = $1; next arg; }; - /^-pgmc(.*)$/ && do { $CcUnregd = $1; next arg; }; + /^-pgmcO?(.*)$/ && do { $CcRegd = $1; next arg; }; # the O? for back compat /^-pgma(.*)$/ && do { $As = $1; next arg; }; /^-pgml(.*)$/ && do { $Lnkr = $1; next arg; }; @@ -847,15 +829,8 @@ arg: while($_ = $ARGV[0]) { # these allow arbitrary option-strings to go to any phase: /^-optL(.*)$/ && do { push(@Unlit_flags, $1); next arg; }; /^-optP(.*)$/ && do { push(@HsCpp_flags, $1); next arg; }; - /^-optp(.*)$/ && do { push(@HsP_flags, $1); next arg; }; /^-optCrts(.*)$/&& do { push(@HsC_rts_flags, $1); next arg; }; /^-optC(.*)$/ && do { push(@HsC_flags, $1); next arg; }; - /^-optcNhc(.*)$/ && do { push(@CcUnregd_flags_hc,$1); next arg; }; - /^-optcNc(.*)$/ && do { push(@CcUnregd_flags_c,$1); next arg; }; - /^-optcN(.*)$/ && do { push(@CcUnregd_flags, $1); next arg; }; - /^-optcOhc(.*)$/&& do { push(@CcRegd_flags_hc,$1); next arg; }; - /^-optcOc(.*)$/ && do { push(@CcRegd_flags_c, $1); next arg; }; - /^-optcO(.*)$/ && do { push(@CcRegd_flags, $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; }; @@ -868,46 +843,27 @@ arg: while($_ = $ARGV[0]) { $genSPECS_flag = $_; next arg; }; - #---------- Haskell parser (hsp) --------------------------------------- - /^-ddump-parser$/ && do { $Dump_parser_output = 1; next arg; }; - #---------- post-Haskell "assembler"------------------------------------ - /^-ddump-raw-asm$/ && do { $Dump_raw_asm = 1; next arg; }; - /^-ddump-asm-insn-counts$/ && do { $Dump_asm_insn_counts = 1; next arg; }; - /^-ddump-asm-globals-info$/ && do { $Dump_asm_globals_info = 1; next arg; }; - + /^-ddump-raw-asm$/ && do { $Dump_raw_asm = 1; next arg; }; /^-ddump-asm-splitting-info$/ && do { $Dump_asm_splitting_info = 1; next arg; }; #---------- Haskell compiler (hsc) ------------------------------------- -# possibly resurrect LATER -# /^-fspat-profiling$/ && do { push(@HsC_flags, '-fticky-ticky'); -# $ProduceS = ''; $ProduceC = 1; # must use C compiler -# push(@CcBoth_flags, '-DDO_SPAT_PROFILING'); -# push(@CcBoth_flags, '-fno-schedule-insns'); # not essential -# next arg; }; - /^-keep-hc-files?-too$/ && do { $Keep_hc_file_too = 1; next arg; }; /^-keep-s-files?-too$/ && do { $Keep_s_file_too = 1; next arg; }; - /^-fhaskell-1\.3$/ && do { $haskell1_version = 3; - push(@HsP_flags, '-3'); - push(@HsC_flags, $_); - $TopClosureFile =~ s/TopClosureXXXX/TopClosure13XXXX/; - unshift(@SysImport_dir, - $(INSTALLING) - ? "$InstDataDirGhc/imports/haskell-1.3" - : "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/haskell-1.3"); + /^-fhaskell-1\.3$/ && do { next arg; }; # a no-op right now - unshift(@SysLibrary, '-lHS13'); + /^-fignore-interface-pragmas$/ && do { push(@HsC_flags, $_); next arg; }; - next arg; }; + /^-fno-implicit-prelude$/ && do { $NoImplicitPrelude= 1; push(@HsC_flags, $_); next arg; }; - /^-fno-implicit-prelude$/ && do { push(@HsP_flags, '-P'); next arg; }; - /^-fignore-interface-pragmas$/ && do { push(@HsP_flags, '-p'); next arg; }; + # ToDo: rename to -fcompiling-ghc-internals=<module> + /^-fcompiling-ghc-internals(.*)/ && do { local($m) = &grab_arg_arg('-fcompiling-ghc-internals',$1); + push(@HsC_flags, "-fcompiling-ghc-internals=$m"); + next arg; }; - /^-prelude$/ && do { $CompilingPrelude = 1; - push(@HsC_flags, $_); next arg; }; + /^-fusing-ghc-internals$/ && do { $UsingGhcInternals = 1; next arg; }; /^-user-prelude-force/ && do { # ignore if not -user-prelude next arg; }; @@ -916,37 +872,36 @@ arg: while($_ = $ARGV[0]) { local($sname) = &grab_arg_arg('-split-objs', $1); $sname =~ s/ //g; # no spaces - if ( $TargetPlatform =~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/ ) { + if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/ ) { + $SplitObjFiles = 0; + print STDERR "WARNING: don't know how to split objects on this platform: $TargetPlatform\n`-split-objs' option ignored\n"; + } else { $SplitObjFiles = 1; - $ProduceS = ''; - $ProduceC = 1; + $HscOut = '-C='; - push(@HsC_flags, "-fglobalise-toplev-names$sname"); + push(@HsC_flags, "-fglobalise-toplev-names=$sname"); push(@CcBoth_flags, '-DUSE_SPLIT_MARKERS'); require('ghc-split.prl') || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-split.prl!\n"); - } else { - $SplitObjFiles = 0; - print STDERR "WARNING: don't know how to split objects on this platform: $TargetPlatform\n`-split-objs' option ignored\n"; } next arg; }; /^-f(hide-builtin-names|min-builtin-names)$/ && do { push(@HsC_flags, $_); - push(@HsP_flags, '-P'); # don't read Prelude.hi - push(@HsP_flags, '-N'); # allow foo# names +# push(@HsC_flags, '-fno-implicit-prelude'); # don't read Prelude.hi +# push(@HsP_flags, '-N'); # allow foo# names next arg; }; - /^-f(glasgow-exts|hide-builtin-instances)$/ + /^-fglasgow-exts$/ && do { push(@HsC_flags, $_); push(@HsP_flags, '-N'); # push(@HsC_flags, '-fshow-import-specs'); - if ( ! $(INSTALLING) ) { - unshift(@SysImport_dir, - "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/glaExts"); - } +# if ( ! $(INSTALLING) ) { +# unshift(@SysImport_dir, +# "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/glaExts"); +# } next arg; }; /^-fspeciali[sz]e-unboxed$/ @@ -954,18 +909,16 @@ arg: while($_ = $ARGV[0]) { $Oopt_SpecialiseUnboxed = '-fspecialise-unboxed'; next arg; }; /^-fspeciali[sz]e$/ - && do { $Oopt_DoSpecialise = '-fspecialise'; - next arg; }; + && do { $Oopt_DoSpecialise = '-fspecialise'; next arg; }; /^-fno-speciali[sz]e$/ - && do { $Oopt_DoSpecialise = ''; - next arg; }; + && do { $Oopt_DoSpecialise = ''; next arg; }; # Now the foldr/build options, which are *on* by default (for -O). /^-ffoldr-build$/ && do { $Oopt_FoldrBuild = 1; - $Oopt_FB_Support = '-fdo-new-occur-anal -fdo-arity-expand'; + $Oopt_FB_Support = '-fdo-arity-expand'; #print "Yes F/B\n"; next arg; }; @@ -991,16 +944,10 @@ arg: while($_ = $ARGV[0]) { # && do { $Oopt_FoldrBuildWW = 1; next arg; }; - /^-fasm-(.*)$/ && do { $ProduceS = $1; $ProduceC = 0; # force using nativeGen - push(@HsC_flags, $_); # if from the command line - next arg; }; + # --------------- - /^-fvia-C$/ && do { $ProduceS = ''; $ProduceC = 1; # force using C compiler - next arg; }; - - /^-f(no-)?omit-frame-pointer$/ && do { - unshift(@CcBoth_flags, ( $_ )); - next arg; }; + /^-fasm-(.*)$/ && do { $HscOut = '-S='; next arg; }; # force using nativeGen + /^-fvia-C$/ && do { $HscOut = '-C='; next arg; }; # force using C compiler # --------------- @@ -1027,15 +974,12 @@ arg: while($_ = $ARGV[0]) { if ($num < 2 || $num > 8) { die "Bad experimental flag: $_\n"; } else { - $ProduceS = ''; $ProduceC = 1; # force using C compiler + $HscOut = '-C='; # force using C compiler push(@HsC_flags, "$what$num"); push(@CcRegd_flags, "-D__STG_REGS_AVAIL__=$num"); } next arg; }; -# /^-flambda-lift$/ # so Simon can do some testing; ToDo:rm -# && do { $Oopt_LambdaLift = $_; next arg; }; - # --------------- /^-fno-(.*)$/ && do { push(@HsC_antiflags, "-f$1"); @@ -1059,27 +1003,8 @@ arg: while($_ = $ARGV[0]) { $StolenX86Regs = $1; next arg; }; - /^-mtoggle-sp-mangling/ && do { # for iX86 boxes only; for RTS only - print STDERR "$Pgm: warning: -mtoggle-sp-mangling is no longer supported\n"; -# $SpX86Mangling = 1 - $SpX86Mangling; - next arg; }; - #*************** ... and lots of debugging ones (form: -d* ) - /^-darity-checks$/ && do { - push(@HsC_flags, $_); - push(@CcBoth_flags, '-D__DO_ARITY_CHKS__'); - next arg; }; - /^-darity-checks-C-only$/ && do { - # so we'll have arity-checkable .hc files - # should we decide we need them later... - push(@HsC_flags, '-darity-checks'); - next arg; }; - /^-dno-stk-checks$/ && do { - push(@HsC_flags, '-dno-stk-chks'); - push(@CcBoth_flags, '-D__OMIT_STK_CHKS__'); - next arg; }; - # -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; }; @@ -1093,9 +1018,6 @@ arg: while($_ = $ARGV[0]) { #*************** ... and now all these -R* ones for its runtime system... - /^-Rhbc$/ && do { $RTS_style = 'hbc'; next arg; }; - /^-Rghc$/ && do { $RTS_style = 'ghc'; next arg; }; - /^-Rscale-sizes?(.*)/ && do { $Scale_sizes_by = &grab_arg_arg('-Rscale-sizes', $1); next arg; }; @@ -1149,11 +1071,6 @@ arg: while($_ = $ARGV[0]) { /^-Rghc-timing/ && do { $CollectGhcTimings = 1; next arg; }; #---------- C high-level assembler (gcc) ------------------------------- -# OLD: and dangerous -# /^-g$/ && do { push(@CcBoth_flags, $_); next arg; }; -# /^-(p|pg)$/ && do { push(@CcBoth_flags, $_); push(@Ld_flags, $_); next arg; }; -# /^-(fpic|fPIC)$/ && do { push(@CcBoth_flags, $_); push(@As_flags, $_); next arg; }; - /^-(Wall|ansi|pedantic)$/ && do { push(@CcBoth_flags, $_); next arg; }; # -dgcc-lint is a useful way of making GCC very fussy. @@ -1176,20 +1093,14 @@ arg: while($_ = $ARGV[0]) { #---------- mixed cc and linker magic ---------------------------------- # this optimisation stuff is finally sorted out later on... -# /^-O0$/ && do { # turn all optimisation *OFF* -# $OptLevel = -1; -# $ProduceS = ''; $ProduceC = 1; # force use of C compiler -# next arg; }; - /^-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; - if ( $OptLevel == 2 ) { # force use of C compiler - $ProduceS = ''; $ProduceC = 1; - } + $HscOut = '-C=' if $OptLevel == 2; # force use of C compiler next arg; }; /^-Onot$/ && do { $OptLevel = 0; next arg; }; # # set it to <no opt> @@ -1278,17 +1189,20 @@ if ($Specific_output_dir ne '' && $Specific_output_file ne '') { if ( ! $PROFing ) { # warn about any scc exprs found (in case scc used as identifier) push(@HsP_flags, '-W'); -} else { - $Oopt_AddAutoSccs = '-fadd-auto-sccs' if $PROFauto; - $Oopt_FinalStgProfilingMassage = '-fmassage-stg-for-profiling'; + # 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; -#UNUSED: push(@HsC_flags, $PROFdict) if $PROFdict; + #push(@HsC_flags, $PROFdict) if $PROFdict; + + $Oopt_FinalStgProfilingMassage = '-fmassage-stg-for-profiling'; push(@HsP_flags, (($PROFignore_scc) ? $PROFignore_scc : '-S')); - if ($SplitObjFiles && ! $CompilingPrelude) { + 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...) @@ -1366,19 +1280,10 @@ It really really wants to be the last STG-to-STG pass that is run. \end{description} \begin{code} -# OLD: -#@HsC_minusO0_flags -# = ( $Oopt_AddAutoSccs, -# '-fsimplify', # would rather *not* run the simplifier (ToDo) -# '\(', '\)', # nothing special at all ???? -# -# $Oopt_FinalStgProfilingMassage -# ); - @HsC_minusNoO_flags = ( '-fsimplify', '\(', - "$Oopt_FB_Support", + $Oopt_FB_Support, # '-falways-float-lets-from-lets', # no idea why this was here (WDP 95/09) '-ffloat-lets-exposing-whnf', '-ffloat-primops-ok', @@ -1386,12 +1291,12 @@ It really really wants to be the last STG-to-STG pass that is run. # '-fdo-lambda-eta-expansion', # too complicated '-freuse-con', # '-flet-to-case', # no strictness analysis, so... - "$Oopt_PedanticBottoms", -# "$Oopt_MonadEtaExpansion", # no thanks + $Oopt_PedanticBottoms, +# $Oopt_MonadEtaExpansion, # no thanks '-fsimpl-uf-use-threshold0', '-fessential-unfoldings-only', -# "$Oopt_UnfoldingUseThreshold", # no thanks - "$Oopt_MaxSimplifierIterations", +# $Oopt_UnfoldingUseThreshold, # no thanks + $Oopt_MaxSimplifierIterations, '\)', $Oopt_AddAutoSccs, # '-ffull-laziness', # removed 95/04 WDP following Andr\'e's lead @@ -1402,19 +1307,17 @@ It really really wants to be the last STG-to-STG pass that is run. @HsC_minusO_flags # NOTE: used for *both* -O and -O2 (some conditional bits) = ( - # initial simplify: mk specialiser and autoscc happy: minimum effort please + # initial simplify: mk specialiser happy: minimum effort please '-fsimplify', '\(', - "$Oopt_FB_Support", + $Oopt_FB_Support, '-fkeep-spec-pragma-ids', # required before specialisation '-fsimpl-uf-use-threshold0', '-fessential-unfoldings-only', '-fmax-simplifier-iterations1', - "$Oopt_PedanticBottoms", + $Oopt_PedanticBottoms, '\)', - $Oopt_AddAutoSccs, # need some basic simplification first - ($Oopt_DoSpecialise) ? ( '-fspecialise-overloaded', $Oopt_SpecialiseUnboxed, @@ -1423,7 +1326,7 @@ It really really wants to be the last STG-to-STG pass that is run. '-fsimplify', # need dependency anal after specialiser ... '\(', # need tossing before calc-inlinings ... - "$Oopt_FB_Support", + $Oopt_FB_Support, '-ffloat-lets-exposing-whnf', '-ffloat-primops-ok', '-fcase-of-case', @@ -1431,10 +1334,10 @@ It really really wants to be the last STG-to-STG pass that is run. '-fdo-eta-reduction', '-fdo-lambda-eta-expansion', '-freuse-con', - "$Oopt_PedanticBottoms", - "$Oopt_MonadEtaExpansion", - "$Oopt_UnfoldingUseThreshold", - "$Oopt_MaxSimplifierIterations", + $Oopt_PedanticBottoms, + $Oopt_MonadEtaExpansion, + $Oopt_UnfoldingUseThreshold, + $Oopt_MaxSimplifierIterations, '\)', '-fcalc-inlinings1', @@ -1444,7 +1347,7 @@ It really really wants to be the last STG-to-STG pass that is run. # '-ffoldr-build-worker-wrapper', # '-fsimplify', # '\(', -# "$Oopt_FB_Support", +# $Oopt_FB_Support, # '-ffloat-lets-exposing-whnf', # '-ffloat-primops-ok', # '-fcase-of-case', @@ -1452,10 +1355,10 @@ It really really wants to be the last STG-to-STG pass that is run. # '-fdo-eta-reduction', # '-fdo-lambda-eta-expansion', # '-freuse-con', -# "$Oopt_PedanticBottoms", -# "$Oopt_MonadEtaExpansion", -# "$Oopt_UnfoldingUseThreshold", -# "$Oopt_MaxSimplifierIterations", +# $Oopt_PedanticBottoms, +# $Oopt_MonadEtaExpansion, +# $Oopt_UnfoldingUseThreshold, +# $Oopt_MaxSimplifierIterations, # '\)', # ) : (), @@ -1470,7 +1373,7 @@ It really really wants to be the last STG-to-STG pass that is run. '\(', '-fignore-inline-pragma', # **** NB! '-fdo-foldr-build', # NB - "$Oopt_FB_Support", + $Oopt_FB_Support, '-ffloat-lets-exposing-whnf', '-ffloat-primops-ok', '-fcase-of-case', @@ -1478,10 +1381,10 @@ It really really wants to be the last STG-to-STG pass that is run. '-fdo-eta-reduction', '-fdo-lambda-eta-expansion', '-freuse-con', - "$Oopt_PedanticBottoms", - "$Oopt_MonadEtaExpansion", - "$Oopt_UnfoldingUseThreshold", - "$Oopt_MaxSimplifierIterations", + $Oopt_PedanticBottoms, + $Oopt_MonadEtaExpansion, + $Oopt_UnfoldingUseThreshold, + $Oopt_MaxSimplifierIterations, '\)', ) : (), @@ -1489,7 +1392,7 @@ It really really wants to be the last STG-to-STG pass that is run. '-fsimplify', '\(', - "$Oopt_FB_Support", + $Oopt_FB_Support, '-ffloat-lets-exposing-whnf', '-ffloat-primops-ok', '-fcase-of-case', @@ -1501,17 +1404,17 @@ It really really wants to be the last STG-to-STG pass that is run. # you need to inline foldr and build ($Oopt_FoldrBuild) ? ('-fdo-foldr-build') : (), # but do reductions if you see them! - "$Oopt_PedanticBottoms", - "$Oopt_MonadEtaExpansion", - "$Oopt_UnfoldingUseThreshold", - "$Oopt_MaxSimplifierIterations", + $Oopt_PedanticBottoms, + $Oopt_MonadEtaExpansion, + $Oopt_UnfoldingUseThreshold, + $Oopt_MaxSimplifierIterations, '\)', '-fstrictness', '-fsimplify', '\(', - "$Oopt_FB_Support", + $Oopt_FB_Support, '-ffloat-lets-exposing-whnf', '-ffloat-primops-ok', '-fcase-of-case', @@ -1520,10 +1423,10 @@ It really really wants to be the last STG-to-STG pass that is run. '-fdo-lambda-eta-expansion', '-freuse-con', '-flet-to-case', # Aha! Only done after strictness analysis - "$Oopt_PedanticBottoms", - "$Oopt_MonadEtaExpansion", - "$Oopt_UnfoldingUseThreshold", - "$Oopt_MaxSimplifierIterations", + $Oopt_PedanticBottoms, + $Oopt_MonadEtaExpansion, + $Oopt_UnfoldingUseThreshold, + $Oopt_MaxSimplifierIterations, '\)', '-ffloat-inwards', @@ -1533,13 +1436,13 @@ It really really wants to be the last STG-to-STG pass that is run. # ( ($OptLevel != 2) # ? '' -# : "-fliberate-case -fsimplify \\( "$Oopt_FB_Support" -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fdo-eta-reduction -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MonadEtaExpansion $Oopt_UnfoldingUseThreshold $Oopt_MaxSimplifierIterations \\)" ), +# : "-fliberate-case -fsimplify \\( $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fdo-eta-reduction -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MonadEtaExpansion $Oopt_UnfoldingUseThreshold $Oopt_MaxSimplifierIterations \\)" ), # Final clean-up simplification: '-fsimplify', '\(', - "$Oopt_FB_Support", + $Oopt_FB_Support, '-ffloat-lets-exposing-whnf', '-ffloat-primops-ok', '-fcase-of-case', @@ -1552,10 +1455,10 @@ It really really wants to be the last STG-to-STG pass that is run. $Oopt_FoldrBuildInline, ($Oopt_FoldrBuild) ? ('-fdo-foldr-build') : (), # but still do reductions if you see them! - "$Oopt_PedanticBottoms", - "$Oopt_MonadEtaExpansion", - "$Oopt_UnfoldingUseThreshold", - "$Oopt_MaxSimplifierIterations", + $Oopt_PedanticBottoms, + $Oopt_MonadEtaExpansion, + $Oopt_UnfoldingUseThreshold, + $Oopt_MaxSimplifierIterations, '\)', # '-fstatic-args', @@ -1581,14 +1484,10 @@ It really really wants to be the last STG-to-STG pass that is run. Sort out what we're going to do about optimising. First, the @hsc@ flags and regular @cc@ flags to worry about: \begin{code} -#if ( $OptLevel < 0 ) { - -# &add_Hsc_flags( @HsC_minusO0_flags ); - if ( $OptLevel <= 0 ) { # for this level, we tell the parser -fignore-interface-pragmas - push(@HsP_flags, '-p'); + push(@HsC_flags, '-fignore-interface-pragmas'); # and tell the compiler not to produce them push(@HsC_flags, '-fomit-interface-pragmas'); @@ -1612,31 +1511,24 @@ if ( $OptLevel <= 0 ) { %************************************************************************ %* * -\subsection{Check for registerising, consistency, etc.} +\subsection{Check for consistency, etc.} %* * %************************************************************************ -Are we capable of generating ``registerisable'' C (either using -C or via equivalent native code)? - -\begin{code} -$RegisteriseC = ( $GccAvailable - && $RegisteriseC ne 'no' # not explicitly *un*set... - && ($TargetPlatform =~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/) - ) ? 'o' : ''; -\end{code} - Sort out @$BuildTag@, @$PROFing@, @$CONCURing@, @$PARing@, @$GRANing@, @$TICKYing@: \begin{code} if ( $BuildTag ne '' ) { local($b) = $BuildDescr{$BuildTag}; - if ($PROFing eq 'p') { print STDERR "$Pgm: Can't mix $b with profiling.\n"; exit 1; } 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'}); } + } elsif ( $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; } @@ -1671,11 +1563,9 @@ if ( $BuildTag ne '' ) { \begin{code} if ( $BuildTag ne '' ) { # something other than normal sequential... - push(@HsP_flags, "-g$BuildTag.hi"); # use appropriate Prelude .hi files + push(@HsP_flags, "-syshisuffix=$BuildTag.hi"); # use appropriate Prelude .hi files - $ProduceC = 1; $ProduceS = ''; # must go via C - -# print STDERR "eval...",$EvaldSetupOpts{$BuildTag},"\n"; + $HscOut = '-C='; # must go via C eval($EvaldSetupOpts{$BuildTag}); } @@ -1684,7 +1574,7 @@ if ( $BuildTag ne '' ) { # something other than normal sequential... Decide what the consistency-checking options are in force for this run: \begin{code} $HsC_consist_options = "${BuildTag},${DEBUGging}"; -$Cc_consist_options = "${BuildTag},${DEBUGging},${RegisteriseC}"; +$Cc_consist_options = "${BuildTag},${DEBUGging}"; \end{code} %************************************************************************ @@ -1704,28 +1594,24 @@ if ($TargetPlatform =~ /^alpha-/) { # we know how to *mangle* asm for alpha unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK; - unshift(@CcBoth_flags, ('-static')) if $GccAvailable; + unshift(@CcBoth_flags, ('-static')); } elsif ($TargetPlatform =~ /^hppa/) { # we know how to *mangle* asm for hppa unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); - unshift(@CcBoth_flags, ('-static')) if $GccAvailable; + 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). - unshift(@CcBoth_flags, ('-D_HPUX_SOURCE')) if $GccAvailable; + 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.) } elsif ($TargetPlatform =~ /^i386-/) { # we know how to *mangle* asm for X86 unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); - unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) - if $StkChkByPageFaultOK && $TargetPlatform !~ /linux/; - # NB: cannot do required signal magic on Linux for such stk chks */ - - unshift(@CcRegd_flags, ('-m486')); # not worth not doing + unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK; # -fno-defer-pop : basically the same game as for m68k # @@ -1737,8 +1623,6 @@ if ($TargetPlatform =~ /^alpha-/) { unshift(@CcRegd_flags, '-fomit-frame-pointer'); unshift(@CcRegd_flags, "-DSTOLEN_X86_REGS=$StolenX86Regs"); - unshift(@CcBoth_flags, ('-static')) if $GccAvailable; # maybe unnecessary??? - } elsif ($TargetPlatform =~ /^m68k-/) { # we know how to *mangle* asm for m68k unshift (@CcRegd_flags, ('-D__STG_REV_TBLS__')); @@ -1759,6 +1643,12 @@ if ($TargetPlatform =~ /^alpha-/) { # maybe gives reg alloc a better time # also: -fno-defer-pop is not sufficiently well-behaved without it +} elsif ($TargetPlatform =~ /^mips-/) { + # we (hope to) know how to *mangle* asm for MIPSen + unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); + unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK; + unshift(@CcBoth_flags, ('-static')); + } elsif ($TargetPlatform =~ /^powerpc-/) { # we know how to *mangle* asm for PowerPC unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); @@ -1769,11 +1659,6 @@ if ($TargetPlatform =~ /^alpha-/) { unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK; -} elsif ($TargetPlatform =~ /^mips-/) { - # we (hope to) know how to *mangle* asm for MIPSen - unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__')); - unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK; - unshift(@CcBoth_flags, ('-static')) if $GccAvailable; } \end{code} @@ -1783,36 +1668,27 @@ Should really be whether or not we prepend underscores to global symbols, not an architecture test. (JSM) \begin{code} +$Under = ( $TargetPlatform =~ /^alpha-/ + || $TargetPlatform =~ /^hppa/ + || $TargetPlatform =~ /^mips-sgi-irix/ + || $TargetPlatform =~ /^powerpc-/ + || $TargetPlatform =~ /-solaris/ + || $TargetPlatform =~ /-linux$/ + ) + ? '' : '_'; + unshift(@Ld_flags, - ( $TargetPlatform =~ /^alpha-/ - || $TargetPlatform =~ /^hppa/ - || $TargetPlatform =~ /^mips-sgi-irix/ - || $TargetPlatform =~ /^powerpc-/ - || $TargetPlatform =~ /-solaris/ - ) - ? (($Ld_main) ? ( - '-u', 'Main_' . $Ld_main . '_closure', - ) : (), - '-u', 'unsafePerformPrimIO_fast1', - '-u', 'Nil_closure', - '-u', 'IZh_static_info', - '-u', 'False_inregs_info', - '-u', 'True_inregs_info', - '-u', 'CZh_static_info', - '-u', 'DEBUG_REGS') # just for fun, now... - - # nice friendly a.out machines... - : (($Ld_main) ? ( - '-u', '_Main_' . $Ld_main . '_closure', + (($Ld_main) ? ( + '-u', "${Under}Main_" . $Ld_main . '_closure', ) : (), - '-u', '_unsafePerformPrimIO_fast1', - '-u', '_Nil_closure', - '-u', '_IZh_static_info', - '-u', '_False_inregs_info', - '-u', '_True_inregs_info', - '-u', '_CZh_static_info', - '-u', '_DEBUG_REGS') - ); + '-u', "${Under}GHCbase_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")) + ; # just for fun, now... \end{code} %************************************************************************ @@ -1827,19 +1703,18 @@ Ready for Business. \begin{code} # default includes must be added AFTER option processing -if ( $(INSTALLING) ) { +if ( ! $(INSTALLING) ) { + push (@Include_dir, "$TopPwd/$(CURRENT_DIR)/$(GHC_INCLUDESRC)"); +} else { push (@Include_dir, "$InstLibDirGhc/includes"); push (@Include_dir, "$InstDataDirGhc/includes"); - -} else { - push (@Include_dir, "$TopPwd/$(CURRENT_DIR)/$(GHC_INCLUDESRC)"); } \end{code} \begin{code} local($f); foreach $f (@SysLibrary) { - $f .= "${BuildTag}" if $f =~ /^-lHS/; + $f .= $BuildTag if $f =~ /^-lHS/; } # fiddle the TopClosure file name... @@ -1896,7 +1771,7 @@ Record largest specific heapsize, if any. $Specific_heap_size = $Specific_heap_size * $Scale_sizes_by; push(@HsC_rts_flags, '-H'.$Specific_heap_size); $Specific_stk_size = $Specific_stk_size * $Scale_sizes_by; -push(@HsC_rts_flags, (($RTS_style eq 'ghc') ? '-K' : '-A').$Specific_stk_size); +push(@HsC_rts_flags, "-K$Specific_stk_size"); # hack to avoid running hscpp $HsCpp = $Cat if ! $Cpp_flag_set; @@ -1906,15 +1781,19 @@ If no input or link files seen, then we let 'em feed in stdin; this is mainly for debugging. \begin{code} if ($#Input_file < 0 && $#Link_file < 0) { - push(@Input_file, '-'); + @Input_file = ( '-' ); + + open(INF, "> $Tmp_prefix.hs") || &tidy_up_and_die(1,"Can't open $Tmp_prefix.hs\n"); + print STDERR "Enter your Haskell program, end with ^D (on a line of its own):\n"; + while (<>) { print INF $_; } + close(INF) || &tidy_up_and_die(1,"Failed writing to $Tmp_prefix.hs\n"); } \end{code} Tell the world who we are, if they asked. \begin{code} -if ($Verbose) { - print STDERR "$(PROJECTNAME), version $(PROJECTVERSION) $(PROJECTPATCHLEVEL)\n"; -} +print STDERR "$(PROJECTNAME), version $(PROJECTVERSION) $(PROJECTPATCHLEVEL)\n" + if $Verbose; \end{code} %************************************************************************ @@ -1940,19 +1819,18 @@ if ( $Status > 0 ) { # don't link if there were errors... Link if appropriate. \begin{code} if ($Do_lnkr) { - local($libdirs); + local($libdirs) = ''; + # glue them together: push(@UserLibrary_dir, @SysLibrary_dir); - if ($#UserLibrary_dir < 0) { - $libdirs = ''; - } else { - $libdirs = '-L' . join(' -L',@UserLibrary_dir); - } + + $libdirs = '-L' . join(' -L',@UserLibrary_dir) if $#UserLibrary_dir >= 0; + # for a linker, use an explicitly given one, or the going C compiler ... - local($lnkr) = ( $Lnkr ) ? $Lnkr : ($RegisteriseC ? $CcRegd : $CcUnregd ); + local($lnkr) = ( $Lnkr ) ? $Lnkr : $CcRegd; - local($output)= ($Specific_output_file ne '') ? "-o $Specific_output_file" : ''; - @Files_to_tidy = ($Specific_output_file ne '') ? "$Specific_output_file" : 'a.out'; + local($output) = ($Specific_output_file ne '') ? "-o $Specific_output_file" : ''; + @Files_to_tidy = ($Specific_output_file ne '') ? $Specific_output_file : 'a.out'; local($to_do) = "$lnkr $Verbose @Ld_flags $output @Link_file $TopClosureFile $libdirs @UserLibrary @SysLibrary"; &run_something($to_do, 'Linker'); @@ -1990,7 +1868,7 @@ if ($Do_lnkr) { $pvm_executable = $ENV{'PVM_ROOT'} . '/bin/' . $ENV{'PVM_ARCH'} . "/$pvm_executable"; - &run_something("rm -f $pvm_executable; cp -p $executable $pvm_executable && rm -f $executable", 'Moving binary to PVM land'); + &run_something("$Rm -f $pvm_executable; $Cp -p $executable $pvm_executable && $Rm -f $executable", 'Moving binary to PVM land'); # OK, now create the magic script for "$executable" open(EXEC, "> $executable") || &tidy_up_and_die(1,"$Pgm: couldn't open $executable to write!\n"); @@ -2042,7 +1920,7 @@ print STDERR "Exec failed!!!: $SysMan $debug $nprocessors @nonPVM_args\n"; exit(1); EOSCRIPT2 close(EXEC) || die "Failed closing $executable\n"; - chmod 0755, "$executable"; + chmod 0755, $executable; } } @@ -2059,452 +1937,383 @@ exit $Status; # will still be 0 if all went well \begin{code} sub ProcessInputFile { - local($ifile) = @_; # input file name - local($ifile_root); # root of or basename of input file - local($ifile_root_file); # non-directory part of $ifile_root + local($ifile) = @_; # input file name + local($ifile_root); # root of or basename of input file + local($ofile_target); # ultimate output file we hope to produce + # from input file (need to know for recomp + # checking purposes) + local($hifile_target);# ditto (but .hi file) \end{code} Handle the weirdity of input from stdin. \begin{code} - if ($ifile eq '-') { - open(INF, "> $Tmp_prefix.hs") || &tidy_up_and_die(1,"Can't open $Tmp_prefix.hs\n"); - print STDERR "Enter your Haskell program, end with ^D (on a line of its own):\n"; - while (<>) { print INF $_; } - close(INF) || &tidy_up_and_die(1,"Failed writing to $Tmp_prefix.hs\n"); - $ifile = "$Tmp_prefix.hs"; - $ifile_root = '_stdin'; - $ifile_root_file = $ifile_root; + if ($ifile ne '-') { + ($ifile_root = $ifile) =~ s/\.[^\.\/]+$//; + $ofile_target = # may be reset later... + ($Specific_output_file ne '' && ! $Do_lnkr) + ? $Specific_output_file + : &odir_ify($ifile_root, 'o'); + $hifile_target= ($Specific_hi_file ne '') + ? $Specific_hi_file + : "$ifile_root.$HiSuffix"; # ToDo: odirify? + # NB: may change if $ifile_root isn't module name (??) } else { - ($ifile_root = $ifile) =~ s/\.[^\.\/]+$//; - ($ifile_root_file = $ifile_root) =~ s|.*/||; + $ifile = "$Tmp_prefix.hs"; # we know that's where we put the input + $ifile_root = '_stdin'; + $ofile_target = '_stdout'; # gratuitous? + $hifile_target= '_stdout'; # ditto? } \end{code} -We now decide what phases of the compilation system we will run over -this file. The defaults are the ones established when processing flags. -(That established what the last phase run for all files is.) +We need to decide what phases of the compilation system we will run +over this file. The defaults are the ones established when processing +flags. (That established what the last phase run for all files is.) -The lower-case names are the local ones (as is usual), just for this -one file. +We do the pre-recompilation-checker phases here; the rest later. \begin{code} - local($do_lit2pgm) = $Do_lit2pgm; - local($do_hscpp) = $Do_hscpp; - local($do_hsp) = $Do_hsp; - local($do_hsc) = $Do_hsc; - local($do_as) = $Do_as; - local($do_cc) = ( $Do_cc != -1) # i.e., it was set explicitly - ? $Do_cc - : ( ($ProduceC) ? 1 : 0 ); \end{code} Look at the suffix and decide what initial phases of compilation may be dropped off for this file. Also the rather boring business of which files are coming-in/going-out. + +Again, we'll do the post-recompilation-checker parts of this later. \begin{code} + 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_hsp) = "$Tmp_prefix.cpp"; - local($hsp_hsc) = "$Tmp_prefix.hsp"; - local($hsc_cc) = "$Tmp_prefix.hc"; - - # to help C compilers grok .hc files [ToDo: de-hackify] - local($cc_help) = "ghc$$.c"; - local($cc_help_s) = "ghc$$.s"; - - local($hsc_hi) = "$Tmp_prefix$HiSuffix"; + 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"; - local($as_out) = ($Specific_output_file ne '' && ! $Do_lnkr) - ? $Specific_output_file - : &odir_ify("${ifile_root}${Osuffix}"); + local($cc_as) = "$Tmp_prefix.s"; # mangled or hsc-produced .s code + local($as_out) = $ofile_target; - local($is_hc_file) = 1; #Is the C code .hc or .c + local($is_hc_file) = 1; #Is the C code .hc or .c? Assume .hc for now if ($ifile =~ /\.lhs$/) { - push(@Link_file, &odir_ify("${ifile_root}${Osuffix}")); + ; # nothing to change } elsif ($ifile =~ /\.hs$/) { $do_lit2pgm = 0; $lit2pgm_hscpp = $ifile; - push(@Link_file, &odir_ify("${ifile_root}${Osuffix}")); } elsif ($ifile =~ /\.hc$/) { - $do_lit2pgm = 0; $do_hscpp = 0; $do_hsp = 0; $do_hsc = 0; $do_cc = 1; - $hsc_cc = $ifile; - push(@Link_file, &odir_ify("${ifile_root}${Osuffix}")); + $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_hsp = 0; $do_hsc = 0; $do_cc = 1; - $hsc_cc = $ifile; $is_hc_file = 0; - push(@Link_file, &odir_ify("${ifile_root}${Osuffix}")); + $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_hsp = 0; $do_hsc = 0; $do_cc = 0; + $do_lit2pgm = 0; $do_hscpp = 0; $do_hsc = 0; $do_cc = 0; $cc_as = $ifile; - push(@Link_file, &odir_ify("${ifile_root}${Osuffix}")); - } else { - if ($ifile !~ /\.a$/) { - print STDERR "$Pgm: don't recognise suffix on `$ifile'; passing it through to linker\n"; - } - $do_lit2pgm = 0; $do_hscpp = 0; $do_hsp = 0; $do_hsc = 0; $do_cc = 0; $do_as = 0; - push(@Link_file, $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; } + + # OK, have a bash on the first two phases: + &runLit2pgm($in_lit2pgm, $lit2pgm_hscpp) + if $do_lit2pgm; + + &runHscpp($in_lit2pgm, $lit2pgm_hscpp, $hscpp_hsc) + if $do_hscpp; \end{code} +We now think about whether to run hsc/cc or not (when hsc produces .s +stuff, it effectively takes the place of both phases). + To get the output file name right: for each phase that we are {\em -not} going to run, set its input (i.e., the output of its preceding phase) to -@"$ifile_root.<suffix>"@. +not} going to run, set its input (i.e., the output of its preceding +phase) to @"$ifile_root.<suffix>"@. \begin{code} - # lit2pgm -- no preceding phase - if (! $do_hscpp) { - $lit2pgm_hscpp = "$ifile_root.lpp????"; # not done - } - if (! $do_hsp) { - $hscpp_hsp = "$ifile_root.cpp????"; # not done - } - if (! $do_hsc) { - $hsp_hsc = "$ifile_root.hsp????"; # not done - } - if (! $do_cc) { - $hsc_cc = &odir_ify("$ifile_root.hc"); - } - if (! $do_as) { - if ($Specific_output_file ne '') { - $cc_as = $Specific_output_file; - } else { - $cc_as = &odir_ify(( $Only_preprocess_C ) ? "$ifile_root.i" : "$ifile_root.s"); - } - } -\end{code} + local($going_interactive) = $HscOut eq '-N=' || $ifile_root eq '_stdin'; -OK, now do it! Note that we don't come back from a @run_something@ if -it fails. -\begin{code} - if ($do_lit2pgm) { - local($to_do) = "echo '#line 1 \"$in_lit2pgm\"' > $lit2pgm_hscpp; ". - "$Unlit @Unlit_flags $in_lit2pgm - >> $lit2pgm_hscpp"; - @Files_to_tidy = ( $lit2pgm_hscpp ); - &run_something($to_do, 'literate pre-processor'); - } - if ($do_hscpp) { - # ToDo: specific output? - if ($HsCpp eq $Cat) { - local($to_do) = "echo '#line 1 \"$in_lit2pgm\"' > $hscpp_hsp; ". - "$HsCpp $lit2pgm_hscpp >> $hscpp_hsp"; - @Files_to_tidy = ( $hscpp_hsp ); - &run_something($to_do, 'Ineffective C pre-processor'); - } else { - local($includes) = '-I' . join(' -I',@Include_dir); - local($to_do) = "echo '#line 1 \"$in_lit2pgm\"' > $hscpp_hsp; ". - "$HsCpp $Verbose $genSPECS_flag @HsCpp_flags -D__HASKELL1__=$haskell1_version -D__GLASGOW_HASKELL__=$ghc_version_info $includes $lit2pgm_hscpp >> $hscpp_hsp"; - @Files_to_tidy = ( $hscpp_hsp ); - &run_something($to_do, 'Haskellised C pre-processor'); - } - } - if ($do_hsp) { - # glue imports onto HsP_flags - # if new parser, then put a comma on the front of all of them. - local($hsprefix) = ($do_hsp == 2) ? ',' : ''; - - foreach $a ( @HsP_flags ) { $a = "$hsprefix$a" unless $a =~ /^,/; } - foreach $dir ( @Import_dir ) { push(@HsP_flags, "$hsprefix-I$dir"); } - foreach $dir ( @SysImport_dir ) { push(@HsP_flags, "$hsprefix-J$dir"); } + if (! $do_cc && ! $do_as) { # stopping after hsc + $hsc_out = ($Specific_output_file ne '') + ? $Specific_output_file + : &odir_ify($ifile_root, ($HscOut eq '-C=') ? 'hc' : 's'); + + $ofile_target = $hsc_out; # reset } - if ($do_hsp == 1) { # "old" parser - local($to_do) = "$HsP $Verbose @HsP_flags $hscpp_hsp > $hsp_hsc"; - @Files_to_tidy = ( $hsp_hsc ); - &run_something($to_do, 'Haskell parser'); - if ($Dump_parser_output) { - print STDERR `$Cat $hsp_hsc`; - } - @HsP_flags = (); # reset! + if (! $do_as) { # stopping after gcc (or hsc) + $cc_as = ($Specific_output_file ne '') + ? $Specific_output_file + : &odir_ify($ifile_root, ( $Only_preprocess_C ) ? 'i' : 's'); + + $ofile_target = $cc_as; # reset } - if ($do_hsc) { - # here, we may produce .hc and/or .hi files - local($output) = ''; - local($c_source) = "$ifile_root.hc"; - local($c_output) = $hsc_cc; # defaults - local($s_output) = $cc_as; - local($hi_output) = "$ifile_root$HiSuffix"; - local($going_interactive) = 0; - - if ($Specific_output_file ne '' && ! $do_cc) { - $c_source = $c_output = $Specific_output_file; - @Files_to_tidy = ( $Specific_output_file ) if $Specific_output_file ne '-'; - } - if ($Specific_hi_file ne '') { - # we change the suffix (-hisuf) even if a specific -ohi file: - $Specific_hi_file =~ s/\.hi$/$HiSuffix/; - $hi_output = $Specific_hi_file; - @Files_to_tidy = ( $Specific_hi_file ) if $Specific_hi_file ne '-'; - } - if ( ! ($ProduceC || $ProduceS) - || $ifile_root eq '_stdin' # going interactive... - || ($c_output eq '-' && $hi_output eq '-')) { - $going_interactive = 1; -#OLD: $output = '1>&2'; # interactive/debugging, to stderr - @Files_to_tidy = (); - # don't need .hi (unless magic value "2" says we wanted it anyway): - if ( $ProduceHi == 2 ) { - $output .= " -hi$hsc_hi"; - unlink($hsc_hi); # needs to be cleared; will be appended to - } else { - $ProduceHi = 0; - } - $do_cc = 0; $do_as = 0; $Do_lnkr = 0; # and we won't go any further... - } +\end{code} - if ( ! $going_interactive ) { - if ( $ProduceHi ) { - # we always go to a temp file for these (for later diff'ing) - $output = "-hi$hsc_hi"; - unlink($hsc_hi); # needs to be cleared; will be appended to - @Files_to_tidy = ( $hsc_hi ); - } - if ( $ProduceC ) { - $output .= " -C$c_output"; - push(@Files_to_tidy, $c_output); - - open(CFILE, "> $c_output") || &tidy_up_and_die(1,"$Pgm: failed to open `$c_output' (to write)\n"); - print CFILE "#line 2 \"$c_source\"\n"; - close(CFILE) || &tidy_up_and_die(1,"Failed writing to $c_output\n"); - # the "real" C output will then be appended - } - if ( $ProduceS ) { - $output .= " -fasm-$ProduceS -S$s_output"; - push(@Files_to_tidy, $s_output); - - # ToDo: ummm,... this isn't doing anything (WDP 94/11) - open(SFILE, "> $s_output") || &tidy_up_and_die(1,"$Pgm: failed to open `$s_output' (to write)\n"); - close(SFILE) || &tidy_up_and_die(1,"Failed writing to $s_output\n"); - # the "real" assembler output will then be appended - } - } +Check if hsc needs to be run at all. - # if we're compiling foo.hs, we want the GC stats to end up in foo.stat - if ( $CollectingGCstats ) { - if ($RTS_style eq 'hbc') { - push(@HsC_rts_flags, '-S'); # puts it in "STAT" - } else { - push(@HsC_rts_flags, "-S$ifile_root.stat"); - push(@Files_to_tidy, "$ifile_root.stat"); - } - } +\begin{code} + local($more_processing_required) = 1; - if ( $CollectGhcTimings ) { # assume $RTS_style eq 'ghc' - # emit nofibbish time/bytes-alloc stats to stderr; - # see later .stat file post-processing - push(@HsC_rts_flags, "-s$Tmp_prefix.stat"); - push(@Files_to_tidy, "$Tmp_prefix.stat"); - } + if ( $Do_recomp_chkr && $do_hsc && ! $going_interactive ) { + # recompilation-checking is important enough to live off by itself + require('ghc-recomp.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-recomp.prl!\n"); - local($dump); - if ($Specific_dump_file ne '') { - $dump = "2>> $Specific_dump_file"; - $Using_dump_file = 1; - } else { - $dump = ''; - } - - local($to_do); - if ($RTS_style eq 'hbc') { - # NB: no parser flags - $to_do = "$HsC < $hsp_hsc $dump @HsC_rts_flags - @HsC_flags $CoreLint $Verbose $output"; - } elsif ($do_hsp == 1) { # old style parser -- no HsP_flags - $to_do = "$HsC < $hsp_hsc $dump @HsC_flags $CoreLint $Verbose $output +RTS @HsC_rts_flags"; - } else { # new style - $to_do = "$HsC ,-H @HsP_flags ,$hscpp_hsp $dump @HsC_flags $CoreLint $Verbose $output +RTS @HsC_rts_flags"; - } - &run_something($to_do, 'Haskell compiler'); + $more_processing_required + = &runRecompChkr($ifile, $hscpp_hsc, $ifile_root, $ofile_target, $hifile_target); - # compensate further for HBC's -S rts opt: - if ($CollectingGCstats && $RTS_style eq 'hbc') { - unlink("$ifile_root.stat"); - rename('STAT', "$ifile_root.stat"); - } + print STDERR "$Pgm:recompile: NOT NEEDED!\n" if ! $more_processing_required; + } - # finish business w/ nofibbish time/bytes-alloc stats - &process_ghc_timings() if $CollectGhcTimings; + $do_hsc = 0, $do_cc = 0, $do_as = 0 if ! $more_processing_required; +\end{code} - # if non-interactive, heave in the consistency info at the end - # NB: pretty hackish (depends on how $output is set) - if ( ! $going_interactive ) { - if ( $ProduceC ) { - $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $c_output"; - } - if ( $ProduceS ) { - local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - $to_do = "echo '\n\t.text\n$consist:' >> $s_output"; - } - &run_something($to_do, 'Pin on Haskell consistency info'); - } +\begin{code} + if ( $do_hsc ) { + + &runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive); - # call the special mangler to produce the .hi/.h(h?) files... - &diff_hi_file($hsc_hi, $hi_output) - if $ProduceHi == 1 && ! $going_interactive; -#OLD: &extract_c_and_hi_files("$Tmp_prefix.hsc", $c_output, $hi_output, $c_source) + # interface-handling is important enough to live off by itself + require('ghc-iface.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n"); - # if we produced an interface file "no matter what", - # print what we got on stderr (ToDo: honor -ohi flag) - if ( $ProduceHi == 2 ) { - print STDERR `$Cat $hsc_hi`; - } + &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive); # save a copy of the .hc file, even if we are carrying on... - if ($ProduceC && $do_cc && $Keep_hc_file_too) { - local($to_do) = "$(RM) $ifile_root.hc; cp $c_output $ifile_root.hc"; + if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) { + local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc"; &run_something($to_do, 'Saving copy of .hc file'); } # save a copy of the .s file, even if we are carrying on... - if ($ProduceS && $do_as && $Keep_s_file_too) { - local($to_do) = "$(RM) $ifile_root.s; cp $cc_as $ifile_root.s"; + if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) { + local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s"; &run_something($to_do, 'Saving copy of .s file'); } # if we're going to split up object files, # we inject split markers into the .hc file now - if ( $ProduceC && $SplitObjFiles ) { - &inject_split_markers ( $c_output ); + if ( $HscOut eq '-C=' && $SplitObjFiles ) { + &inject_split_markers ( $hsc_out ); } } + if ($do_cc) { + &runGcc ($is_hc_file, $hsc_out, $cc_as_o); + &runMangler($is_hc_file, $cc_as_o, $cc_as, $ifile_root); + } + + &split_asm_file($cc_as) if $do_as && $SplitObjFiles; + + &runAs($as_out, $ifile_root) if $do_as; +\end{code} + +Finally, decide what to queue up for linker input. +\begin{code} + # tentatively assume we will eventually produce linker input: + push(@Link_file, &odir_ify($ifile_root, 'o')); + + if ($ifile !~ /\.(lhs|hs|hc|c|s)$/) { + print STDERR "$Pgm: don't recognise suffix on `$ifile'; passing it through to linker\n" + if $ifile !~ /\.a$/; + + # oops; we tentatively pushed the wrong thing; fix & do the right thing + pop(@Link_file); push(@Link_file, $ifile); + } + +} # end of ProcessInputFile +\end{code} + +%************************************************************************ +%* * +\section[Driver-run-phases]{Routines to run the various phases} +%* * +%************************************************************************ + +\begin{code} +sub runLit2pgm { + local($in_lit2pgm, $lit2pgm_hscpp) = @_; + + local($to_do) = "echo '#line 1 \"$in_lit2pgm\"' > $lit2pgm_hscpp && ". + "$Unlit @Unlit_flags $in_lit2pgm - >> $lit2pgm_hscpp"; + @Files_to_tidy = ( $lit2pgm_hscpp ); + + &run_something($to_do, 'literate pre-processor'); +} +\end{code} + +\begin{code} +sub runHscpp { + local($in_lit2pgm, $lit2pgm_hscpp, $hscpp_hsc) = @_; + + local($to_do); + + if ($HsCpp eq $Cat) { + $to_do = "echo '#line 1 \"$in_lit2pgm\"' > $hscpp_hsc && ". + "$HsCpp $lit2pgm_hscpp >> $hscpp_hsc"; + @Files_to_tidy = ( $hscpp_hsc ); + &run_something($to_do, 'Ineffective C pre-processor'); + } else { local($includes) = '-I' . join(' -I',@Include_dir); - local($cc); - local($s_output); - local($c_flags) = "@CcBoth_flags"; - local($ddebug_flag) = ( $DEBUGging ) ? '-DDEBUG' : ''; - if ($RegisteriseC) { - $cc = $CcRegd; - $s_output = ($is_hc_file || $TargetPlatform =~ /^(hppa|i386)/) ? $cc_as_o : $cc_as; - $c_flags .= " @CcRegd_flags"; - $c_flags .= ($is_hc_file) ? " @CcRegd_flags_hc" : " @CcRegd_flags_c"; - } else { - $cc = $CcUnregd; - $s_output = $cc_as; - $c_flags .= " @CcUnregd_flags"; - $c_flags .= ($is_hc_file) ? " @CcUnregd_flags_hc" : " @CcUnregd_flags_c"; - } - - # C compiler won't like the .hc extension. So we create - # a tmp .c file which #include's the needful. - open(TMP, "> $cc_help") || &tidy_up_and_die(1,"$Pgm: failed to open `$cc_help' (to write)\n"); - if ( $is_hc_file ) { - print TMP <<EOINCL; -#ifdef __STG_GCC_REGS__ -# if ! (defined(MAIN_REG_MAP) || defined(MARK_REG_MAP) || defined(SCAN_REG_MAP) || defined(SCAV_REG_MAP) || defined(FLUSH_REG_MAP)) -# define MAIN_REG_MAP -# endif -#endif -#include "stgdefs.h" -EOINCL - # user may have asked for #includes to be injected... - print TMP @CcInjects if $#CcInjects >= 0; - } - # heave in the consistency info - print TMP "static char ghc_cc_ID[] = \"\@(#)cc $ifile\t$Cc_major_version.$Cc_minor_version,$Cc_consist_options\";\n"; + $to_do = "echo '#line 1 \"$in_lit2pgm\"' > $hscpp_hsc && ". + "$HsCpp $Verbose $genSPECS_flag @HsCpp_flags -D__HASKELL1__=$Haskell1Version -D__GLASGOW_HASKELL__=$GhcVersionInfo $includes $lit2pgm_hscpp >> $hscpp_hsc"; + @Files_to_tidy = ( $hscpp_hsc ); + &run_something($to_do, 'Haskellised C pre-processor'); + } +} +\end{code} - # and #include the real source - print TMP "#include \"$hsc_cc\"\n"; - close(TMP) || &tidy_up_and_die(1,"Failed writing to $cc_help\n"); +\begin{code} +sub runHsc { + local($ifile_root, $hsc_out, $hsc_hi, $going_interactive) = @_; - local($to_do) = "$cc $Verbose $ddebug_flag $c_flags @Cpp_define -D__HASKELL1__=$haskell1_version $includes $cc_help > $Tmp_prefix.ccout 2>&1 && ( if [ $cc_help_s != $s_output ] ; then mv $cc_help_s $s_output ; else exit 0 ; fi )"; - # note: __GLASGOW_HASKELL__ is pointedly *not* #defined at the C level. - if ( $Only_preprocess_C ) { # HACK ALERT! - $to_do =~ s/ -S\b//g; - } - @Files_to_tidy = ( $cc_help, $cc_help_s, $s_output ); - $PostprocessCcOutput = 1; # hack, dear hack... - &run_something($to_do, 'C compiler'); - $PostprocessCcOutput = 0; - unlink($cc_help, $cc_help_s); - - if ( ($RegisteriseC && $is_hc_file) - || $Dump_asm_insn_counts - || $Dump_asm_globals_info ) { - # dynamically load assembler-fiddling code, which we are about to use - local($target) = 'oops'; - $target = '-alpha' if $TargetPlatform =~ /^alpha-/; - $target = '-hppa' if $TargetPlatform =~ /^hppa/; - $target = '' if $TargetPlatform =~ /^i386-/; - $target = '-m68k' if $TargetPlatform =~ /^m68k-/; - $target = '-mips' if $TargetPlatform =~ /^mips-/; - $target = '' if $TargetPlatform =~ /^powerpc-/; - $target = '-solaris' if $TargetPlatform =~ /^sparc-sun-solaris2/; - $target = '-sparc' if $TargetPlatform =~ /^sparc-sun-sunos4/; - - $target ne 'oops' - || &tidy_up_and_die(1,"$Pgm: panic: can't decipher $TargetPlatform!\n"); - require("ghc-asm$target.prl") - || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm$target.prl!\n"); - } + # prepend comma to HsP flags (so hsc can tell them apart...) + foreach $a ( @HsP_flags ) { $a = ",$a" unless $a =~ /^,/; } - if ( $Dump_raw_asm ) { # to stderr, before mangling - local($to_pr) = ($RegisteriseC) ? $cc_as_o : $cc_as ; - print STDERR `cat $to_pr`; - } + &makeHiMap() unless $HiMapDone; + push(@HsC_flags, "-himap=$HiMapFile"); - if ($RegisteriseC) { - if ($is_hc_file) { - # post-process the assembler [.hc files only] - &mangle_asm($cc_as_o, $cc_as); - - } elsif ($TargetPlatform =~ /^hppa/) { - # minor mangling of non-threaded files for hp-pa only - require('ghc-asm-hppa.prl') - || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm-hppa.prl!\n"); - &mini_mangle_asm($cc_as_o, $cc_as); - - } elsif ($TargetPlatform =~ /^i386/) { - # extremely-minor OFFENSIVE mangling of non-threaded just one file - require('ghc-asm.prl') - || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm.prl!\n"); - &mini_mangle_asm($cc_as_o, $cc_as); - } - } + # here, we may produce .hc/.s and/or .hi files + local($output) = ''; + @Files_to_tidy = (); - # collect interesting (static-use) info - &dump_asm_insn_counts($cc_as) if $Dump_asm_insn_counts; - &dump_asm_globals_info($cc_as) if $Dump_asm_globals_info; + if ( $going_interactive ) { + # don't need .hi unless going to show it on stdout: + $ProduceHi = '-nohifile=' if ! $HiOnStdout; + $do_cc = 0; $do_as = 0; $Do_lnkr = 0; # and we won't go any further... + } - # save a copy of the .s file, even if we are carrying on... - if ($do_as && $Keep_s_file_too) { - local($to_do) = "$(RM) $ifile_root.s; cp $cc_as $ifile_root.s"; - &run_something($to_do, 'Saving copy of .s file'); - } + # set up for producing output/.hi; note that flag twiddling + # may mean that nothing will actually be produced: + $output = "$ProduceHi$hsc_hi $HscOut$hsc_out"; + @Files_to_tidy = ( $hsc_hi, $hsc_out ); + + # if we're compiling foo.hs, we want the GC stats to end up in foo.stat + if ( $CollectingGCstats ) { + push(@HsC_rts_flags, "-S$ifile_root.stat"); + push(@Files_to_tidy, "$ifile_root.stat"); } - if ($do_as) { - # if we're splitting .o files... - if ( $SplitObjFiles ) { - &split_asm_file ( $cc_as ); - } + if ( $CollectGhcTimings ) { # assume $RTS_style eq 'ghc' + # emit nofibbish time/bytes-alloc stats to stderr; + # see later .stat file post-processing + push(@HsC_rts_flags, "-s$Tmp_prefix.stat"); + push(@Files_to_tidy, "$Tmp_prefix.stat"); + } - local($asmblr) = ( $As ) ? $As : ($RegisteriseC ? $CcRegd : $CcUnregd ); + local($dump) = ''; + if ($Specific_dump_file ne '') { + $dump = "2>> $Specific_dump_file"; + $Using_dump_file = 1; + } - if ( ! $SplitObjFiles ) { - local($to_do) = "$asmblr -o $as_out -c @As_flags $cc_as"; - @Files_to_tidy = ( $as_out ); - &run_something($to_do, 'Unix assembler'); + local($to_do); + $to_do = "$HsC @HsP_flags ,$hscpp_hsc $dump @HsC_flags $CoreLint $Verbose $output +RTS @HsC_rts_flags"; + &run_something($to_do, 'Haskell compiler'); + + # finish business w/ nofibbish time/bytes-alloc stats + &process_ghc_timings() if $CollectGhcTimings; + + # if non-interactive, heave in the consistency info at the end + # NB: pretty hackish (depends on how $output is set) + if ( ! $going_interactive ) { + if ( $HscOut eq '-C=' ) { + $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out"; + + } elsif ( $HscOut eq '-S=' ) { + local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options"; + $consist =~ s/,/./g; + $consist =~ s/\//./g; + $consist =~ s/-/_/g; + $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? + $to_do = "echo '\n\t.text\n$consist:' >> $hsc_out"; + } + &run_something($to_do, 'Pin on Haskell consistency info'); + } +} +\end{code} - } else { # more complicated split-ification... +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 = (); +$HiMapDone = 0; +$HiMapFile = ''; - # must assemble files $Tmp_prefix__[1 .. $NoOfSplitFiles].s +sub makeHiMap { - for ($f = 1; $f <= $NoOfSplitFiles; $f++ ) { - local($split_out) = &odir_ify("${ifile_root}__${f}${Osuffix}"); - local($to_do) = "$asmblr -o $split_out -c @As_flags ${Tmp_prefix}__${f}.s"; - @Files_to_tidy = ( $split_out ); + # collect in %HiMap; write later; also used elsewhere in driver - &run_something($to_do, 'Unix assembler'); + local($mod, $path, $d, $e); + + foreach $d ( @Import_dir ) { + 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; + $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"); } -} # end of ProcessInputFile + + foreach $d ( @SysImport_dir ) { + 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_]*)\.$SysHiSuffix$/o; + next if $NoImplicitPrelude && $e =~ /Prelude\.$SysHiSuffix$/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"); + + $HiMapDone = 1; +} + +sub already_mapped_err { + local($mod, $mapped_to, $path) = @_; + + # OK, it isn't really an error if $mapped_to and $path turn + # out to be the same thing. + ($m_dev,$m_ino,$m_mode,$m_nlink,$m_uid,$m_gid,$m_rdev,$m_size, + $m_atime,$m_mtime,$m_ctime,$m_blksize,$m_blocks) = stat($mapped_to); + ($p_dev,$p_ino,$p_mode,$p_nlink,$p_uid,$p_gid,$p_rdev,$p_size, + $p_atime,$p_mtime,$p_ctime,$p_blksize,$p_blocks) = stat($path); + + return if $m_ino == $p_ino; # same inode number + + print STDERR "$Pgm: module $mod already mapped to $mapped_to (inode $m_ino)"; + print STDERR ";\n\tignoring: $path (inode $p_ino)\n"; +} \end{code} %************************************************************************ @@ -2520,14 +2329,157 @@ EOINCL %************************************************************************ \begin{code} +sub osuf_ify { + local($ofile,$def_suffix) = @_; + + return(($Osuffix eq '') ? "$ofile.$def_suffix" : "$ofile.$Osuffix" ); +} + sub odir_ify { - local($orig_file) = @_; + local($orig_file, $def_suffix) = @_; if ($Specific_output_dir eq '') { # do nothing - return($orig_file); + &osuf_ify($orig_file, $def_suffix); } else { local ($orig_file_only); ($orig_file_only = $orig_file) =~ s|.*/||; - return("$Specific_output_dir/$orig_file_only"); + &osuf_ify("$Specific_output_dir/$orig_file_only",$def_suffix); + } +} +\end{code} + +\begin{code} +sub runGcc { + local($is_hc_file, $hsc_out, $cc_as_o) = @_; + + local($includes) = '-I' . join(' -I', @Include_dir); + local($cc); + local($s_output); + local($c_flags) = "@CcBoth_flags"; + local($ddebug_flag) = ( $DEBUGging ) ? '-DDEBUG' : ''; + + # "input" files to use that are not in some weird directory; + # to help C compilers grok .hc files [ToDo: de-hackify] + local($cc_help) = "ghc$$.c"; + local($cc_help_s) = "ghc$$.s"; + + $cc = $CcRegd; + $s_output = ($is_hc_file || $TargetPlatform =~ /^(hppa|i386)/) ? $cc_as_o : $cc_as; + $c_flags .= " @CcRegd_flags"; + $c_flags .= ($is_hc_file) ? " @CcRegd_flags_hc" : " @CcRegd_flags_c"; + + # C compiler won't like the .hc extension. So we create + # a tmp .c file which #include's the needful. + open(TMP, "> $cc_help") || &tidy_up_and_die(1,"$Pgm: failed to open `$cc_help' (to write)\n"); + if ( $is_hc_file ) { + print TMP <<EOINCL; +#ifdef __STG_GCC_REGS__ +# if ! (defined(MAIN_REG_MAP) || defined(MARK_REG_MAP) || defined(SCAN_REG_MAP) || defined(SCAV_REG_MAP) || defined(FLUSH_REG_MAP)) +# define MAIN_REG_MAP +# endif +#endif +#include "stgdefs.h" +EOINCL + # user may have asked for #includes to be injected... + print TMP @CcInjects if $#CcInjects >= 0; + } + # heave in the consistency info + print TMP "static char ghc_cc_ID[] = \"\@(#)cc $ifile\t$Cc_major_version.$Cc_minor_version,$Cc_consist_options\";\n"; + + # and #include the real source + print TMP "#include \"$hsc_out\"\n"; + close(TMP) || &tidy_up_and_die(1,"Failed writing to $cc_help\n"); + + local($to_do) = "$cc $Verbose $ddebug_flag $c_flags @Cpp_define -D__HASKELL1__=$Haskell1Version $includes $cc_help > $Tmp_prefix.ccout 2>&1 && ( if [ $cc_help_s != $s_output ] ; then mv $cc_help_s $s_output ; else exit 0 ; fi )"; + # note: __GLASGOW_HASKELL__ is pointedly *not* #defined at the C level. + if ( $Only_preprocess_C ) { # HACK ALERT! + $to_do =~ s/ -S\b//g; + } + @Files_to_tidy = ( $cc_help, $cc_help_s, $s_output ); + $PostprocessCcOutput = 1; # hack, dear hack... + &run_something($to_do, 'C compiler'); + $PostprocessCcOutput = 0; + unlink($cc_help, $cc_help_s); +} +\end{code} + +\begin{code} +sub runMangler { + local($is_hc_file, $cc_as_o, $cc_as, $ifile_root) = @_; + + if ( $is_hc_file ) { + # dynamically load assembler-fiddling code, which we are about to use: + require('ghc-asm.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm.prl!\n"); + } + + print STDERR `cat $cc_as_o` if $Dump_raw_asm; # to stderr, before mangling + + if ($is_hc_file) { + # post-process the assembler [.hc files only] + &mangle_asm($cc_as_o, $cc_as); + +#OLD: for sanity: + local($target) = 'oops'; + $target = '-alpha' if $TargetPlatform =~ /^alpha-/; + $target = '-hppa' if $TargetPlatform =~ /^hppa/; + $target = '' if $TargetPlatform =~ /^i386-/; + $target = '-m68k' if $TargetPlatform =~ /^m68k-/; + $target = '-mips' if $TargetPlatform =~ /^mips-/; + $target = '' if $TargetPlatform =~ /^powerpc-/; + $target = '-solaris' if $TargetPlatform =~ /^sparc-sun-solaris2/; + $target = '-sparc' if $TargetPlatform =~ /^sparc-sun-sunos4/; + + if ( $target ne '' ) { + require("ghc-asm$target.prl") + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm$target.prl!\n"); + &mangle_asm($cc_as_o, "$cc_as-2"); # the OLD one! + &run_something("$Cmp -s $cc_as-2 $cc_as || $Diff $cc_as-2 $cc_as 1>&2 || exit 0", + "Diff'ing old and new mangled .s files"); # NB: to stderr + } + + } elsif ($TargetPlatform =~ /^hppa/) { + # minor mangling of non-threaded files for hp-pa only + require('ghc-asm.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm-hppa.prl!\n"); + &mini_mangle_asm_hppa($cc_as_o, $cc_as); + + } elsif ($TargetPlatform =~ /^i386/) { + # extremely-minor OFFENSIVE mangling of non-threaded just one file + require('ghc-asm.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm.prl!\n"); + &mini_mangle_asm_i386($cc_as_o, $cc_as); + } + + # save a copy of the .s file, even if we are carrying on... + if ($do_as && $Keep_s_file_too) { + local($to_do) = "$Rm $ifile_root.s; $Cp $cc_as $ifile_root.s"; + &run_something($to_do, 'Saving copy of .s file'); + } +} +\end{code} + +\begin{code} +sub runAs { + local($as_out, $ifile_root) = @_; + + local($asmblr) = ( $As ) ? $As : $CcRegd; + + if ( ! $SplitObjFiles ) { + local($to_do) = "$asmblr -o $as_out -c @As_flags $cc_as"; + @Files_to_tidy = ( $as_out ); + &run_something($to_do, 'Unix assembler'); + + } else { # more complicated split-ification... + + # must assemble files $Tmp_prefix__[1 .. $NoOfSplitFiles].s + + 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"; + @Files_to_tidy = ( $split_out ); + + &run_something($to_do, 'Unix assembler'); + } } } \end{code} @@ -2592,60 +2544,6 @@ sub run_something { %************************************************************************ %* * -\subsection[Driver-demangle-C-and-hi]{@extract_c_and_hi_files@: Unscramble Haskell-compiler output} -%* * -%************************************************************************ - -Update interface if the tmp one is newer... -We first have to fish the module name out of the interface. -\begin{code} -sub diff_hi_file { - local($tmp_hi_file, $hi_file) = @_; - local($if_modulename) = ''; - - # extract the module name - - open(TMP, "< $tmp_hi_file")|| &tidy_up_and_die(1,"$Pgm: failed to open `$tmp_hi_file' (to read)\n"); - while (<TMP>) { - if ( /^interface ([A-Za-z0-9'_]+) / ) { - $if_modulename = $1; - } - } - close(TMP) || &tidy_up_and_die(1,"Failed reading from $tmp_hi_file\n"); - &tidy_up_and_die(1,"No module name in $tmp_hi_file\n") - if ! $if_modulename; - - #compare/diff with old one - - if ($hi_file eq '-') { - &run_something("cat $tmp_hi_file", "copy interface to stdout"); - - } else { - if ($Specific_hi_file eq '' && $if_modulename ne '') { - if ( $hi_file =~ /\// ) { - $hi_file =~ s/\/[^\/]+$//; - $hi_file .= "/$if_modulename$HiSuffix"; - } else { - $hi_file = "$if_modulename$HiSuffix"; - } - print STDERR "interface really going into: $hi_file\n" if $Verbose; - } - - if ($HiDiff_flag && -f $hi_file) { - local($diffcmd) = '$(CONTEXT_DIFF)'; - - &run_something("cmp -s $tmp_hi_file $hi_file || $(CONTEXT_DIFF) $hi_file $tmp_hi_file 1>&2 || exit 0", - "Diff'ing old and new $HiSuffix files"); # NB: to stderr - } - - &run_something("cmp -s $tmp_hi_file $hi_file || ( $(RM) $hi_file && $(CP) $tmp_hi_file $hi_file )", - "Comparing old and new $HiSuffix files"); - } -} -\end{code} - -%************************************************************************ -%* * \subsection[Driver-ghctiming]{Emit nofibbish GHC timings} %* * %************************************************************************ @@ -2728,7 +2626,7 @@ sub process_ghc_timings { \begin{code} sub tidy_up { - local($to_do) = "\n$(RM) $Tmp_prefix*"; + local($to_do) = "\n$Rm $Tmp_prefix*"; if ( $Tmp_prefix !~ /^\s*$/ ) { print STDERR "$to_do\n" if $Verbose; system($to_do); @@ -2812,3 +2710,4 @@ sub add_Hsc_flags { } } \end{code} + diff --git a/ghc/includes/COptJumps.lh b/ghc/includes/COptJumps.lh index db8516dec9..458c93c944 100644 --- a/ghc/includes/COptJumps.lh +++ b/ghc/includes/COptJumps.lh @@ -254,7 +254,8 @@ register void *_procedure __asm__("$27"); \begin{code} #if i386_TARGET_ARCH -#ifdef solaris2_TARGET_OS +/* *not* a good way to do this (WDP 96/05) */ +#if defined(solaris2_TARGET_OS) || defined(linux_TARGET_OS) #define MINI_INTERPRET_END "miniInterpretEnd" #else #define MINI_INTERPRET_END "_miniInterpretEnd" diff --git a/ghc/includes/COptWraps.lh b/ghc/includes/COptWraps.lh index da57a40e42..4334caec34 100644 --- a/ghc/includes/COptWraps.lh +++ b/ghc/includes/COptWraps.lh @@ -69,9 +69,23 @@ but unfortunately, we have to cater to ANSI C as well.) do {SaveAllStgRegs(); PerformGC(args); RestoreAllStgRegs();} while(0) #define DO_STACKOVERFLOW(headroom,args) \ do {SaveAllStgRegs(); StackOverflow(headroom,args); RestoreAllStgRegs();} while(0) + +#if defined(GRAN) + +#define DO_YIELD(args) DO_GRAN_YIELD(args) +#define DO_GRAN_YIELD(liveness) \ + do {SaveAllStgRegs(); Yield(liveness); RestoreAllStgRegs();} while(0) + +#define DO_PERFORM_RESCHEDULE(liveness_mask,reenter) \ + do {SaveAllStgRegs(); PerformReschedule(liveness_mask,reenter); RestoreAllStgRegs();} while(0) + +#else + #define DO_YIELD(args) \ do {SaveAllStgRegs(); Yield(args); RestoreAllStgRegs();} while(0) +#endif /* GRAN */ + \end{code} %************************************************************************ @@ -168,12 +182,35 @@ extern void callWrapper_safe(STG_NO_ARGS); void PerformGC_wrapper PROTO((W_)); void StackOverflow_wrapper PROTO((W_, W_)); void Yield_wrapper PROTO((W_)); +# ifdef GRAN +void PerformReschedule_wrapper PROTO((W_, W_)); +void GranSimAllocate_wrapper PROTO((I_, P_, W_)); +void GranSimUnallocate_wrapper PROTO((I_, P_, W_)); +void GranSimFetch_wrapper PROTO((P_)); +void GranSimExec_wrapper PROTO((W_, W_, W_, W_, W_)); +# endif #endif #define DO_GC(args) PerformGC_wrapper(args) #define DO_STACKOVERFLOW(headroom,args) StackOverflow_wrapper(headroom,args) + +# ifdef GRAN + +#define DO_YIELD(args) DO_GRAN_YIELD(args) +#define DO_GRAN_YIELD(liveness) Yield_wrapper(liveness) + +#define DO_PERFORMRESCHEDULE(liveness, always_reenter_node) PerformReschedule_wrapper(liveness, always_reenter_node) +#define DO_GRANSIMALLOCATE(n, node, liveness) GranSimAllocate_wrapper(n, node, liveness) +#define DO_GRANSIMUNALLOCATE(n, node, liveness) GranSimUnallocate_wrapper(n, node, liveness) +#define DO_GRANSIMFETCH(node) GranSimFetch_wrapper(node) +#define DO_GRANSIMEXEC(arith,branch,load,store,floats) GranSimExec_wrapper(arith,branch,load,store,floats) + +# else + #define DO_YIELD(args) Yield_wrapper(args) +# endif + #endif /* __GNUC__ && __STG_GCC_REGS__ */ \end{code} @@ -377,7 +414,7 @@ gets whatever it's after. #define WRAPPER_NAME(f) /*nothing*/ -#ifdef solaris2_TARGET_OS +#if defined(solaris2_TARGET_OS) || defined(linux_TARGET_OS) #define REAL_NAME(f) #f #else #define REAL_NAME(f) "_" #f @@ -566,7 +603,6 @@ gets whatever it's after. %************************************************************************ \begin{code} - #if sparc_TARGET_ARCH #define MAGIC_CALL_SETUP \ @@ -577,6 +613,11 @@ gets whatever it's after. "\tstd %i2,[%fp-32]\n" \ "\tstd %i4,[%fp-24]"); +/* We leave nothing to chance here; we have seen + GCC stick "unwanted" code in the branch delay + slot, causing mischief (WDP 96/05) +*/ +#ifdef GRAN #define MAGIC_CALL \ __asm__ volatile ( \ "ld [%%fp-40],%%o5\n" \ @@ -590,6 +631,21 @@ gets whatever it's after. __asm__ volatile ( \ "std %f0,[%fp-40]\n" \ "\tstd %o0,[%fp-32]"); +#else +#define MAGIC_CALL \ + __asm__ volatile ( \ + "ld [%%fp-40],%%o5\n" \ + "\tld [%%fp-36],%%o0\n" \ + "\tld [%%fp-32],%%o1\n" \ + "\tld [%%fp-28],%%o2\n" \ + "\tld [%%fp-24],%%o3\n" \ + "\tld [%%fp-20],%%o4\n" \ + "\tcall %%o5\n" \ + "\tnop\n" \ + "\tstd %%f0,[%%fp-40]\n"\ + "\tstd %%o0,[%%fp-32]" \ + : : : "%o0", "%o1", "%o2", "%o3", "%o4", "%o5", "%f0", "%g1", "%g2", "%g3", "%g4", "memory"); +#endif #define MAGIC_RETURN \ __asm__ volatile ( \ diff --git a/ghc/includes/CostCentre.lh b/ghc/includes/CostCentre.lh index ed1fe26866..79c4272937 100644 --- a/ghc/includes/CostCentre.lh +++ b/ghc/includes/CostCentre.lh @@ -44,19 +44,19 @@ The compiler declares a static block for each @_scc_@ annotation in the source using the @CC_DECLARE@ macro where @label@, @module@ and @group@ are strings and @ident@ the cost centre identifier. -\begin{code} -# define CC_IS_CAF 'C' -# define CC_IS_DICT 'D' +\begin{code} +# define CC_IS_CAF 'c' +# define CC_IS_DICT 'd' # define CC_IS_SUBSUMED 'S' -# define CC_IS_BORING '\0' +# define CC_IS_BORING 'B' # define STATIC_CC_REF(cc_ident) &CAT2(cc_ident,_struct) # define DYN_CC_REF(cc_ident) cc_ident /* unused */ -# define CC_DECLARE(cc_ident,name,module,group,subsumed,is_local) \ - is_local struct cc CAT2(cc_ident,_struct) \ - = {NOT_REGISTERED, UNHASHED, name, module, group, \ - subsumed, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; \ +# define CC_DECLARE(cc_ident,name,module,group,subsumed,is_local) \ + is_local struct cc CAT2(cc_ident,_struct) \ + = {NOT_REGISTERED, UNHASHED, name, module, group, \ + subsumed, INIT_CC_STATS}; \ is_local CostCentre cc_ident = STATIC_CC_REF(cc_ident) #endif /* defined(PROFILING) || defined(CONCURRENT) */ @@ -96,7 +96,9 @@ turn on @PROFILING@. Get them out of the way.... # define SET_CC_HDR(closure, cc) /* Dont set CC header */ # define SET_STATIC_CC_HDR(cc) /* No static CC header */ -# define SET_CCC(cc_ident,is_dupd) +# define SET_CCC(cc_ident,do_scc_count) +# define SET_DICT_CCC(cc_ident,do_scc_count) +# define SET_CCC_RTS(cc_ident,do_sub_count,do_count) # define RESTORE_CCC(cc) @@ -104,6 +106,9 @@ turn on @PROFILING@. Get them out of the way.... # define ENTER_CC_TCL(closure) # define ENTER_CC_F(cc) # define ENTER_CC_FCL(closure) +# define ENTER_CC_FSUB() +# define ENTER_CC_FCAF(cc) +# define ENTER_CC_FLOAD(cc) # define ENTER_CC_PAP(cc) # define ENTER_CC_PAP_CL(closure) @@ -152,7 +157,7 @@ CC_EXTERN(CC_CAFs); /* prelude cost centre (CAFs only) */ CC_EXTERN(CC_DICTs); /* prelude cost centre (DICTs only) */ # define IS_CAF_OR_DICT_CC(cc) \ - (((cc)->is_subsumed == CC_IS_CAF) || ((cc)->is_subsumed == CC_IS_DICT)) + ((cc)->is_subsumed & ' ') /* tests for lower case character */ # define IS_SUBSUMED_CC(cc) ((cc)->is_subsumed == CC_IS_SUBSUMED) @@ -200,14 +205,23 @@ not count the entry to avoid large counts arising from simple recursion. (Huh? WDP 94/07) \begin{code} -# define SET_CCC_X(cc,is_dupd) \ - do { \ - if (!(is_dupd)) { CCC->sub_scc_count++; } /* inc subcc count of CCC */ \ - CCC = (CostCentre)(cc); /* set CCC to ident cc */ \ - if (!(is_dupd)) { CCC->scc_count++; } /* inc scc count of new CCC*/ \ +# define SET_CCC_X(cc,do_subcc_count,do_subdict_count,do_scc_count) \ + do { \ + if ((do_subcc_count)) { CCC->sub_scc_count++; } /* inc subcc count of CCC */ \ + if ((do_subdict_count)) { CCC->sub_dictcc_count++; } /* inc sub dict count of CCC */ \ + CCC = (CostCentre)(cc); /* set CCC to ident cc */ \ + ASSERT_IS_REGISTERED(CCC,1); \ + if ((do_scc_count)) { CCC->scc_count++; } /* inc scc count of new CCC*/ \ } while(0) -# define SET_CCC(cc_ident,is_dupd) SET_CCC_X(STATIC_CC_REF(cc_ident),is_dupd) +# define SET_CCC(cc_ident,do_scc_count) \ + SET_CCC_X(STATIC_CC_REF(cc_ident),do_scc_count,0,do_scc_count) + +# define SET_DICT_CCC(cc_ident,do_scc_count) \ + SET_CCC_X(STATIC_CC_REF(cc_ident),0,do_scc_count,do_scc_count) + +# define SET_CCC_RTS(cc_ident,do_sub_count,do_scc_count) \ + SET_CCC_X(STATIC_CC_REF(cc_ident),do_sub_count,0,do_scc_count) \end{code} We have this @RESTORE_CCC@ macro, rather than just an assignment, @@ -225,9 +239,9 @@ On entry to top level CAFs we count the scc ... # define ENTER_CC_CAF_X(cc) \ do { \ CCC->sub_cafcc_count++; /* inc subcaf count of CCC */ \ - CCC = (CostCentre)(cc); /* set CCC to ident cc */ \ + CCC = (CostCentre)(cc); /* set CCC to ident cc */ \ ASSERT_IS_REGISTERED(CCC,1); \ - CCC->cafcc_count++; /* inc cafcc count of CCC */ \ + CCC->scc_count++; /* inc scc count of CAF cc */ \ } while(0) # define ENTER_CC_CAF(cc_ident) ENTER_CC_CAF_X(STATIC_CC_REF(cc_ident)) @@ -236,14 +250,14 @@ On entry to top level CAFs we count the scc ... On entering a closure we only count the enter to thunks ... \begin{code} -# define ENTER_CC_T(cc) \ - do { \ - CCC = (CostCentre)(cc); \ - ASSERT_IS_REGISTERED(CCC,1); \ - CCC->thunk_count++; /* inc thunk count of new CCC */ \ +# define ENTER_CC_T(cc) \ + do { \ + CCC = (CostCentre)(cc); \ + ASSERT_IS_REGISTERED(CCC,1); \ + CCC_DETAIL_COUNT(CCC->thunk_count); \ } while(0) -# define ENTER_CC_TCL(closure) \ +# define ENTER_CC_TCL(closure) \ ENTER_CC_T(CC_HDR(closure)) /* Here is our special "hybrid" case when we do *not* set the CCC. @@ -256,13 +270,38 @@ On entering a closure we only count the enter to thunks ... ASSERT_IS_REGISTERED(cc,1); \ if ( ! IS_CAF_OR_DICT_CC(cc) ) { \ CCC = cc; \ + } else { \ + CCC_DETAIL_COUNT(cc->caffun_subsumed); \ + CCC_DETAIL_COUNT(CCC->subsumed_caf_count); \ } \ - CCC->function_count++; \ + CCC_DETAIL_COUNT(CCC->function_count); \ } while(0) # define ENTER_CC_FCL(closure) \ ENTER_CC_F(CC_HDR(closure)) +# define ENTER_CC_FSUB() \ + do { \ + CCC_DETAIL_COUNT(CCC->subsumed_fun_count); \ + CCC_DETAIL_COUNT(CCC->function_count); \ + } while(0) + +# define ENTER_CC_FCAF(centre) \ + do { \ + CostCentre cc = (CostCentre) (centre); \ + ASSERT_IS_REGISTERED(cc,1); \ + CCC_DETAIL_COUNT(cc->caffun_subsumed); \ + CCC_DETAIL_COUNT(CCC->subsumed_caf_count); \ + CCC_DETAIL_COUNT(CCC->function_count); \ + } while(0) + +# define ENTER_CC_FLOAD(cc) \ + do { \ + CCC = (CostCentre)(cc); \ + ASSERT_IS_REGISTERED(CCC,1); \ + CCC_DETAIL_COUNT(CCC->function_count); \ + } while(0) + /* These ENTER_CC_PAP things are only used in the RTS */ # define ENTER_CC_PAP(centre) \ @@ -271,13 +310,22 @@ On entering a closure we only count the enter to thunks ... ASSERT_IS_REGISTERED(cc,1); \ if ( ! IS_CAF_OR_DICT_CC(cc) ) { \ CCC = cc; \ + } else { \ + CCC_DETAIL_COUNT(cc->caffun_subsumed); \ + CCC_DETAIL_COUNT(CCC->subsumed_caf_count); \ } \ - CCC->pap_count++; \ + CCC_DETAIL_COUNT(CCC->pap_count); \ } while(0) # define ENTER_CC_PAP_CL(closure) \ ENTER_CC_PAP(CC_HDR(closure)) +# if defined(PROFILING_DETAIL_COUNTS) +# define CCC_DETAIL_COUNT(inc_this) ((inc_this)++) +# else +# define CCC_DETAIL_COUNT(inc_this) /*nothing*/ +# endif + #endif /* PROFILING */ \end{code} @@ -357,7 +405,7 @@ We don't want to attribute costs to an unregistered cost-centre: # define ASSERT_IS_REGISTERED(cc,chk_not_overhead) /*nothing*/ #else # define ASSERT_IS_REGISTERED(cc,chk_not_overhead) \ - do { \ + do { /* beware of cc name-capture */ \ CostCentre c_c = (CostCentre) (cc); \ if (c_c->registered == NOT_REGISTERED) { \ fprintf(stderr,"Entering unregistered CC: %s\n",c_c->label); \ @@ -398,6 +446,8 @@ reuse @CON_K@ (or something) in runtime/main/StgStartup.lhc. Similarily, the SP stuff should probably be the highly uninformative @INTERNAL_KIND@. +SOF 4/96: Renamed MallocPtr_K to ForeignObj_K + \begin{code} #if defined(PROFILING) @@ -409,7 +459,7 @@ Similarily, the SP stuff should probably be the highly uninformative # define ARR_K 6 # ifndef PAR -# define MallocPtr_K 7 /* Malloc Pointer */ +# define ForeignObj_K 7 /* Malloc Pointer */ # define SPT_K 8 /* Stable Pointer Table */ # endif /* !PAR */ @@ -569,19 +619,19 @@ extern hash_t index_type PROTO((ClCategory clcat)); memory alloc macros. \begin{code} -# define CC_TICK(cc) \ - do { CostCentre centre = (CostCentre) (cc); \ - ASSERT_IS_REGISTERED(centre,1); \ - centre->time_ticks += 1; \ +# define CC_TICK(centre) \ + do { CostCentre cc = (CostCentre) (centre); \ + ASSERT_IS_REGISTERED(cc,1); \ + cc->time_ticks += 1; \ } while(0) # if defined(PROFILING) -# define CC_ALLOC(cc, size, kind) \ - do { CostCentre cc_ = (CostCentre) (cc); \ - ASSERT_IS_REGISTERED(cc_,0/*OK if OVERHEAD*/); \ - cc_->mem_allocs += 1; \ - cc_->mem_alloc += (size) - (PROF_FIXED_HDR + TICKY_FIXED_HDR); \ - } while(0) /* beware name-capture by ASSERT_IS...! */ +# define CC_ALLOC(centre, size, kind) \ + do { CostCentre cc = (CostCentre) (centre); \ + ASSERT_IS_REGISTERED(cc,0/*OK if OVERHEAD*/); \ + CCC_DETAIL_COUNT(cc->mem_allocs); \ + cc->mem_alloc += (size) - (PROF_FIXED_HDR + TICKY_FIXED_HDR); \ + } while(0) # endif \end{code} @@ -610,13 +660,7 @@ rtsBool cc_to_ignore PROTO((CostCentre)); \begin{code} # if defined(PROFILING) -extern I_ heap_profile_init PROTO((char *select_cc_str, - char *select_mod_str, - char *select_grp_str, - char *select_descr_str, - char *select_typ_str, - char *select_kind_str, - char *argv[])); +I_ heap_profile_init PROTO((char *argv[])); extern void heap_profile_finish(STG_NO_ARGS); @@ -628,8 +672,11 @@ extern void (* heap_profile_fn) PROTO((P_ closure,I_ size)); extern I_ earlier_ticks; /* no. of earlier ticks grouped */ extern hash_t time_intervals; /* no. of time intervals reported -- 18 */ -# define HEAP_PROFILE_CLOSURE(closure,size) \ - STGCALL2(void,(void *, P_, I_),(*heap_profile_fn),closure,size) /*R SM2s.lh */ +# define HEAP_PROFILE_CLOSURE(closure,size) \ + do { \ + if (heap_profile_fn) { \ + STGCALL2(void,(void *, P_, I_),(*heap_profile_fn),closure,size); \ + }} while(0) # endif /* PROFILING */ \end{code} diff --git a/ghc/includes/GranSim.lh b/ghc/includes/GranSim.lh index eea0b2473a..e2da0d152a 100644 --- a/ghc/includes/GranSim.lh +++ b/ghc/includes/GranSim.lh @@ -7,44 +7,241 @@ %* * %************************************************************************ +Dummy definitions if we are not compiling for GrAnSim. + +\begin{code} +#ifndef GRAN +#define GRAN_ALLOC_HEAP(n,liveness) /* nothing */ +#define GRAN_UNALLOC_HEAP(n,liveness) /* nothing */ +#define GRAN_FETCH() /* nothing */ +#define GRAN_FETCH_AND_RESCHEDULE(liveness) /* nothing */ +#define GRAN_RESCHEDULE(liveness, reenter) /* nothing */ +#define GRAN_EXEC(arith,branch,loads,stores,floats) /* nothing */ +#define GRAN_SPARK() /* nothing */ +#endif +\end{code} + +First the basic types specific to GrAnSim. + \begin{code} -#ifdef GRAN - -# define IS_IDLE(proc) ((IdleProcs & PE_NUMBER((long)proc)) != 0l) -# define ANY_IDLE (Idlers > 0) -# define MAKE_IDLE(proc) do { if(!IS_IDLE(proc)) { ++Idlers; IdleProcs |= PE_NUMBER(proc); } } while(0) -# define MAKE_BUSY(proc) do { if(IS_IDLE(proc)) { --Idlers; IdleProcs &= ~PE_NUMBER(proc); } } while(0) - -/* Event Types */ -# define STARTTHREAD 0 /* Start a newly created thread */ -# define CONTINUETHREAD 1 /* Continue running the first thread in the queue */ -# define RESUMETHREAD 2 /* Resume a previously running thread */ -# define MOVESPARK 3 /* Move a spark from one PE to another */ -# define MOVETHREAD 4 /* Move a thread from one PE to another */ -# define FINDWORK 5 /* Search for work */ -# define FETCHNODE 6 /* Fetch a node */ -# define FETCHREPLY 7 /* Receive a node */ - -# define EVENT_PROC(evt) (evt->proc) -# define EVENT_CREATOR(evt) (evt->creator) -# define EVENT_TIME(evt) (evt->time) -# define EVENT_TYPE(evt) (evt->evttype) -# define EVENT_TSO(evt) (evt->tso) -# define EVENT_NODE(evt) (evt->node) -# define EVENT_SPARK(evt) (evt->spark) -# define EVENT_NEXT(evt) (eventq)(evt->next) - -#endif /* GRAN */ +#if defined(GRAN) +#define GRANSIMSTATS_BINARY RTSflags.GranFlags.granSimStats_Binary +#elif defined(PAR) +#define GRANSIMSTATS_BINARY RTSflags.ParFlags.granSimStats_Binary +#endif + +#ifdef PAR +ullong msTime(STG_NO_ARGS); +# define CURRENT_TIME msTime() +# define TIME_ON_PROC(p) msTime() + +# define CURRENT_PROC thisPE +#endif + +#if defined(GRAN) + +#if !defined(COMPILING_GHC) +#include "RtsFlags.h" +#endif + +# define CURRENT_TIME CurrentTime[CurrentProc] +# define TIME_ON_PROC(p) CurrentTime[p] +# define CURRENT_PROC CurrentProc +#endif #if defined(GRAN) || defined(PAR) + +/* Granularity event types for output (see DumpGranEvent) */ +enum gran_event_types { + GR_START = 0, GR_STARTQ, + GR_STEALING, GR_STOLEN, GR_STOLENQ, + GR_FETCH, GR_REPLY, GR_BLOCK, GR_RESUME, GR_RESUMEQ, + GR_SCHEDULE, GR_DESCHEDULE, + GR_END, + SP_SPARK, SP_SPARKAT, SP_USED, SP_PRUNED, SP_EXPORTED, SP_ACQUIRED, + GR_ALLOC, + GR_TERMINATE, + GR_SYSTEM_START, GR_SYSTEM_END, /* only for debugging */ + GR_EVENT_MAX +}; + +/* Prototypes of functions needed both in GRAN and PAR setup */ void DumpGranEvent PROTO((enum gran_event_types name, P_ tso)); -void DumpSparkGranEvent PROTO((enum gran_event_types name, W_ id)); -void DumpGranEventAndNode PROTO((enum gran_event_types name, P_ tso, P_ node, PROC proc)); -void DumpRawGranEvent PROTO((PROC pe, enum gran_event_types name, W_ id)); -void DumpGranInfo PROTO((PROC pe, P_ tso, rtsBool mandatory_thread)); +void DumpRawGranEvent PROTO((PROC proc, PROC p, enum gran_event_types name, P_ tso, P_ node, I_ len)); +void DumpStartEventAt PROTO((TIME time, PROC proc, PROC p, enum gran_event_types name, + P_ tso, P_ node, I_ len)); +void DumpGranInfo PROTO((PROC proc, P_ tso, rtsBool mandatory_thread)); +void DumpTSO PROTO((P_ tso)); + void grterminate PROTO((TIME v)); +void grputw PROTO((TIME v)); + +extern unsigned CurrentProc; + /* I have no idea what this is supposed to be in the PAR case WDP 96/03 */ + +#endif /* GRAN || PAR */ + +/* ---------- The rest of this file is GRAN only ---------- */ + +#if defined(GRAN) +rtsBool any_idle PROTO((STG_NO_ARGS)); +int idlers PROTO((STG_NO_ARGS)); + +enum proc_status { + Idle = 0, /* empty threadq */ + Sparking, /* non-empty sparkq; FINDWORK has been issued */ + Starting, /* STARTTHREAD has been issue */ + Fetching, /* waiting for remote data (only if block-on-fetch) */ + Fishing, /* waiting for remote spark/thread */ + Busy /* non-empty threadq, with head of queue active */ +}; + +typedef struct event { + PROC proc; /* Processor id */ + PROC creator; /* Processor id of PE that created the event */ + EVTTYPE evttype; /* Event type */ + TIME time; /* Time at which event happened */ + P_ tso; /* Associated TSO, if relevant, Nil_closure otherwise*/ + P_ node; /* Associated node, if relevant, Nil_closure otherwise*/ + sparkq spark; /* Associated SPARK, if relevant, NULL otherwise */ + I_ gc_info; /* Counter of heap objects to mark (used in GC only)*/ + struct event *next; + } *eventq; + +/* Macros for accessing components of the event structure */ +#define EVENT_PROC(evt) (evt->proc) +#define EVENT_CREATOR(evt) (evt->creator) +#define EVENT_TIME(evt) (evt->time) +#define EVENT_TYPE(evt) (evt->evttype) +#define EVENT_TSO(evt) (evt->tso) +#define EVENT_NODE(evt) (evt->node) +#define EVENT_SPARK(evt) (evt->spark) +#define EVENT_GC_INFO(evt) (evt->gc_info) +#define EVENT_NEXT(evt) (eventq)(evt->next) + +/* Maximum number of PEs that can be simulated */ +#define MAX_PROC (BITS_IN(W_)) + +#if 0 +extern W_ IdleProcs, Idlers; +#endif + +/* Processor numbers to bitmasks and vice-versa */ +#define MainProc 0 /* Id of main processor */ +#define MAX_PRI 10000 /* max possible priority */ +#define MAIN_PRI MAX_PRI /* priority of main thread */ + +/* GrAnSim uses IdleProcs as bitmask to indicate which procs are idle */ +#define PE_NUMBER(n) (1l << (long)n) +#define ThisPE PE_NUMBER(CurrentProc) +#define MainPE PE_NUMBER(MainProc) +#define Everywhere (~0l) +#define Nowhere (0l) + +#define IS_LOCAL_TO(ga,proc) ((1l << (long) proc) & ga) + +#define GRAN_TIME_SLICE 1000 /* max time between 2 ReSchedules */ + +#if 1 + +#define IS_IDLE(proc) (procStatus[proc] == Idle) +#define IS_SPARKING(proc) (procStatus[proc] == Sparking) +#define IS_STARTING(proc) (procStatus[proc] == Starting) +#define IS_FETCHING(proc) (procStatus[proc] == Fetching) +#define IS_FISHING(proc) (procStatus[proc] == Fishing) +#define IS_BUSY(proc) (procStatus[proc] == Busy) +#define ANY_IDLE (any_idle()) +#define MAKE_IDLE(proc) do { procStatus[proc] = Idle; } while(0) +#define MAKE_SPARKING(proc) do { procStatus[proc] = Sparking; } while(0) +#define MAKE_STARTING(proc) do { procStatus[proc] = Starting; } while(0) +#define MAKE_FETCHING(proc) do { procStatus[proc] = Fetching; } while(0) +#define MAKE_FISHING(proc) do { procStatus[proc] = Fishing; } while(0) +#define MAKE_BUSY(proc) do { procStatus[proc] = Busy; } while(0) + +#else + +#define IS_IDLE(proc) ((IdleProcs & PE_NUMBER((long)proc)) != 0l) +#define ANY_IDLE (Idlers > 0) +#define MAKE_IDLE(proc) do { \ + if (!IS_IDLE(proc)) { \ + ++Idlers; \ + IdleProcs |= PE_NUMBER(proc); \ + procStatus[proc] = Idle; \ + } \ + } while(0) +#define MAKE_BUSY(proc) do { \ + if (IS_IDLE(proc)) { \ + --Idlers; \ + IdleProcs &= ~PE_NUMBER(proc); \ + procStatus[proc] = Busy; \ + } \ + } while(0) +#endif + +/* Number of last event type */ +#define MAX_EVENT 9 + +/* Event Types (internal use only) */ +#define STARTTHREAD 0 /* Start a newly created thread */ +#define CONTINUETHREAD 1 /* Continue running the first thread in the queue */ +#define RESUMETHREAD 2 /* Resume a previously running thread */ +#define MOVESPARK 3 /* Move a spark from one PE to another */ +#define MOVETHREAD 4 /* Move a thread from one PE to another */ +#define FINDWORK 5 /* Search for work */ +#define FETCHNODE 6 /* Fetch a node */ +#define FETCHREPLY 7 /* Receive a node */ +#define GLOBALBLOCK 8 /* Block a TSO on a remote node */ +#define UNBLOCKTHREAD 9 /* Make a TSO runnable */ + +#if defined(GRAN_CHECK) +/* Prototypes of GrAnSim debugging functions */ +void G_PRINT_NODE(P_); +void G_TREE(P_); +void G_INFO_TABLE(P_); +void G_CURR_THREADQ(I_); +void G_THREADQ(P_, I_); +void G_TSO(P_, I_); +void G_EVENT(eventq, I_); +void G_EVENTQ(I_); +void G_PE_EQ(PROC, I_); +void G_SPARK(sparkq, I_); +void G_SPARKQ(sparkq, I_); +void G_CURR_SPARKQ(I_); +void G_PROC(I_, I_); +void GP(I_); +void GCP(); +void GT(P_); +void GCT(); +void GEQ(); +void GTQ(PROC); +void GCTQ(); +void GSQ(PROC); +void GCSQ(); +void GN(P_); +void GIT(P_); +void pC(P_); +void DN(P_); +void DIT(P_); +void DT(P_); +/* void DS(P_); */ +#endif + +/* Interface to event queues */ +extern eventq EventHd; /* global event queue */ +extern char *event_names[]; +eventq get_next_event PROTO(()); +TIME get_time_of_next_event PROTO(()); +void newevent PROTO((PROC proc, PROC creator, TIME time, EVTTYPE + evttype, P_ tso, P_ node, sparkq spark)); +void prepend_event PROTO((eventq event)); +eventq grab_event PROTO((STG_NO_ARGS)); +void print_event PROTO((eventq event)); +void print_eventq PROTO((eventq hd)); +void print_spark PROTO((sparkq spark)); +void print_sparkq PROTO((sparkq hd)); + +/* void DumpPruneEvent PROTO((PROC proc, sparkq spark)); */ -# ifdef GRAN I_ SaveSparkRoots PROTO((I_)); I_ SaveEventRoots PROTO((I_)); @@ -53,19 +250,179 @@ I_ RestoreEventRoots PROTO((I_)); IF_RTS(int init_gr_simulation PROTO((int, char **, int, char **));) IF_RTS(void end_gr_simulation(STG_NO_ARGS);) -# endif -# ifdef PAR -ullong msTime(STG_NO_ARGS); -# define CURRENT_TIME msTime() +/* These constants are defaults for the RTS flags of GranSim */ -# define CURRENT_PROC thisPE +/* Communication Cost Model (EDS-like), max_proc > 2. */ -# else /* GRAN */ +#define LATENCY 1000 /* Latency for single packet */ +#define ADDITIONAL_LATENCY 100 /* Latency for additional packets */ +#define BASICBLOCKTIME 10 +#define FETCHTIME (LATENCY*2+MSGUNPACKTIME) +#define LOCALUNBLOCKTIME 10 +#define GLOBALUNBLOCKTIME (LATENCY+MSGUNPACKTIME) -# define CURRENT_TIME CurrentTime[CurrentProc] -# define CURRENT_PROC CurrentProc -# endif +#define MSGPACKTIME 0 /* Cost of creating a packet */ +#define MSGUNPACKTIME 0 /* Cost of receiving a packet */ +#define MSGTIDYTIME 0 /* Cost of cleaning up after send */ + +#define MAX_FISHES 1 /* max no. of outstanding spark steals */ +/* How much to increase GrAnSims internal packet size if an overflow + occurs. + NB: This is a GrAnSim internal variable and is independent of the + simulated packet buffer size. +*/ + +#define GRANSIM_DEFAULT_PACK_BUFFER_SIZE 200 +#define REALLOC_SZ 50 +/* extern W_ gran_mpacktime, gran_mtidytime, gran_munpacktime; */ + +/* Thread cost model */ +#define THREADCREATETIME (25+THREADSCHEDULETIME) +#define THREADQUEUETIME 12 /* Cost of adding a thread to the running/runnable queue */ +#define THREADDESCHEDULETIME 75 /* Cost of descheduling a thread */ +#define THREADSCHEDULETIME 75 /* Cost of scheduling a thread */ +#define THREADCONTEXTSWITCHTIME (THREADDESCHEDULETIME+THREADSCHEDULETIME) + +/* Instruction Cost model (SPARC, including cache misses) */ +#define ARITH_COST 1 +#define BRANCH_COST 2 +#define LOAD_COST 4 +#define STORE_COST 4 +#define FLOAT_COST 1 /* ? */ + +#define HEAPALLOC_COST 11 + +#define PRI_SPARK_OVERHEAD 5 +#define PRI_SCHED_OVERHEAD 5 + +/* Miscellaneous Parameters */ +extern rtsBool DoFairSchedule; +extern rtsBool DoReScheduleOnFetch; +extern rtsBool SimplifiedFetch; +extern rtsBool DoStealThreadsFirst; +extern rtsBool DoAlwaysCreateThreads; +extern rtsBool DoThreadMigration; +extern rtsBool DoGUMMFetching; +extern I_ FetchStrategy; +extern rtsBool PreferSparksOfLocalNodes; +extern rtsBool DoPrioritySparking, DoPriorityScheduling; +extern I_ SparkPriority, SparkPriority2, ThunksToPack; +/* These come from debug options -bD? */ +extern rtsBool NoForward; +extern rtsBool PrintFetchMisses; + +extern TIME TimeOfNextEvent, EndOfTimeSlice; /* checked from the threaded world! */ +extern I_ avoidedCS; /* Unused!! ToDo: Remake libraries and nuke this var */ +extern rtsBool IgnoreEvents; /* HACK only for testing */ + +#if defined(GRAN_CHECK) +/* Variables for gathering misc statistics */ +extern I_ tot_low_pri_sparks; +extern I_ rs_sp_count, rs_t_count, ntimes_total, fl_total, no_of_steals; +extern I_ tot_packets, tot_packet_size, tot_cuts, tot_thunks, + tot_sq_len, tot_sq_probes, tot_sparks, withered_sparks, + tot_add_threads, tot_tq_len, non_end_add_threads; +#endif + +extern I_ fetch_misses; +#if defined(GRAN_COUNT) +extern I_ nUPDs, nUPDs_old, nUPDs_new, nUPDs_BQ, nPAPs, BQ_lens; #endif + +extern FILE *gr_file; +/* extern rtsBool no_gr_profile; */ +/* extern rtsBool do_sp_profile; */ + +extern rtsBool NeedToReSchedule; + +void GranSimAllocate PROTO((I_ n, P_ node, W_ liveness)); +void GranSimUnAllocate PROTO((I_ n, P_ node, W_ liveness)); +I_ GranSimFetch PROTO((P_ node)); +void GranSimExec PROTO((W_ ariths, W_ branches, W_ loads, W_ stores, W_ floats)); +void GranSimSpark PROTO((W_ local, P_ node)); +void GranSimSparkAt PROTO((sparkq spark, P_ where, I_ identifier)); +void GranSimSparkAtAbs PROTO((sparkq spark, PROC proc, I_ identifier)); +void GranSimBlock PROTO((P_ tso, PROC proc, P_ node)); +void PerformReschedule PROTO((W_, rtsBool)); + +#define GRAN_ALLOC_HEAP(n,liveness) \ + GranSimAllocate_wrapper(n,0,0); + +#define GRAN_UNALLOC_HEAP(n,liveness) \ + GranSimUnallocate_wrapper(n,0,0); + +#if 0 + +#define GRAN_FETCH() \ + GranSimFetch_wrapper(Node); + +#define GRAN_FETCH_AND_RESCHEDULE(liveness_mask,reenter) \ + do { if(liveness_mask&LIVENESS_R1) \ + SaveAllStgRegs(); \ + GranSimFetch(Node); \ + PerformReschedule(liveness_mask,reenter); \ + RestoreAllStgRegs(); \ + } while(0) + +#define GRAN_RESCHEDULE(liveness_mask,reenter) \ + PerformReschedule_wrapper(liveness_mask,reenter) + +#else + +#define GRAN_FETCH() /*nothing */ + +#define GRAN_FETCH_AND_RESCHEDULE(liveness_mask,reenter) \ + do { if(liveness_mask&LIVENESS_R1) \ + SaveAllStgRegs(); \ + GranSimFetch(Node); \ + PerformReschedule(liveness_mask,reenter); \ + RestoreAllStgRegs(); \ + } while(0) + +#define GRAN_RESCHEDULE(liveness_mask,reenter) GRAN_FETCH_AND_RESCHEDULE(liveness_mask,reenter) + +#endif + +#define THREAD_CONTEXT_SWITCH(liveness_mask,reenter) \ + do { \ + if (context_switch /* OR_INTERVAL_EXPIRED */) { \ + GRAN_RESCHEDULE(liveness_mask,reenter); \ + } }while(0) + +#if 0 + +#define GRAN_EXEC(arith,branch,load,store,floats) \ + GranSimExec_wrapper(arith,branch,load,store,floats); + +#else + +#define GRAN_EXEC(arith,branch,load,store,floats) \ + { \ + W_ cost = RTSflags.GranFlags.gran_arith_cost*arith + \ + RTSflags.GranFlags.gran_branch_cost*branch + \ + RTSflags.GranFlags.gran_load_cost*load + \ + RTSflags.GranFlags.gran_store_cost*store + \ + RTSflags.GranFlags.gran_float_cost*floats; \ + TSO_EXECTIME(CurrentTSO) += cost; \ + CurrentTime[CurrentProc] += cost; \ + } + +#endif + +#define GRAN_YIELD(liveness) \ + do { \ + if ( (CurrentTime[CurrentProc]>=EndOfTimeSlice) || \ + ((CurrentTime[CurrentProc]>=TimeOfNextEvent) && \ + (TimeOfNextEvent!=0) && !IgnoreEvents )) { \ + DO_GRAN_YIELD(liveness); \ + } \ + } while (0); + +#define ADD_TO_SPARK_QUEUE(spark) \ + STGCALL1(void,(),add_to_spark_queue,spark) \ + +#endif /* GRAN */ + \end{code} diff --git a/ghc/includes/Jmakefile b/ghc/includes/Jmakefile index 74ab648339..90a28193e4 100644 --- a/ghc/includes/Jmakefile +++ b/ghc/includes/Jmakefile @@ -63,12 +63,14 @@ PLAT_H_FILES = config.h platform.h #undef __native_h /* Literate-pgmming suffix rules used herein */ -LitSuffixRule(.lh,.h) -LitSuffixRule(.lc,.c) +UnlitSuffixRule(.lh,.h) +UnlitSuffixRule(.lc,.c) all :: /* so it is first */ @: +UnlitNeededHere(depend) + #if GhcWithNativeCodeGen == YES GhcDriverNeededHere(depend all mkNativeHdr.o) /* we use its C-compiling know-how */ @@ -101,9 +103,3 @@ ExtraStuffToClean( $(H_FILES_FROM_LH_FILES) ) EtagsNeededHere(tags) /* need this to do "make tags" */ ClearTagsFile() CTagsTarget( $(H_FILES) ) - -LitStuffNeededHere(docs depend) -InfoStuffNeededHere(docs) - -LitDocRootTargetWithNamedOutput(root,lit,root-standalone) -LitDocRootTargetWithNamedOutput(c-as-asm,lit,c-as-asm-standalone) diff --git a/ghc/includes/Parallel.lh b/ghc/includes/Parallel.lh index cbf0e55660..4d060cf2d0 100644 --- a/ghc/includes/Parallel.lh +++ b/ghc/includes/Parallel.lh @@ -115,8 +115,9 @@ Get this out of the way. These are all null definitions. # define SET_TASK_ACTIVITY(act) /* nothing */ -# else -# ifdef GRAN +#endif + +#if defined(GRAN) # define GA_HDR_SIZE 1 @@ -130,13 +131,10 @@ Get this out of the way. These are all null definitions. PROCS(closure) = (W_)(procs) /* Set closure's location */ # define SET_GRAN_HDR(closure,pe) SET_PROCS(closure,pe) -# if defined(GRAN_TNG) # define SET_STATIC_PROCS(closure) , (W_) (Everywhere) -# else -# define SET_STATIC_PROCS(closure) , (W_) (MainPE) -# endif /* GRAN_TNG */ # define SET_TASK_ACTIVITY(act) /* nothing */ +#endif \end{code} %************************************************************************ @@ -154,7 +152,7 @@ for local closures that have no global address), and @setGA@ to store a new global address for a local closure which did not previously have one. \begin{code} -# else /* it must be PARallel (to end of file) */ +#if defined(PAR) # define GA_HDR_SIZE 0 @@ -445,13 +443,8 @@ Special info-table for local blocking queues. %************************************************************************ \begin{code} -# ifdef GRAN -# define HAVE_SPARK ((PendingSparksHd[REQUIRED_POOL] != Nil_closure) || \ - (PendingSparksHd[ADVISORY_POOL] != Nil_closure)) -# else # define HAVE_SPARK ((PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL]) \ || (PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL])) -# endif # define HAVE_WORK (RUNNING_THREAD || HAVE_SPARK) # define RUNNING_THREAD (CurrentTSO != NULL) @@ -470,33 +463,31 @@ This constant defines how many words of data we can pack into a single packet in the parallel (GUM) system. \begin{code} -# ifdef PAR void InitPackBuffer(STG_NO_ARGS); -P_ PackNearbyGraph PROTO((P_ closure,W_ *size)); P_ PackTSO PROTO((P_ tso, W_ *size)); P_ PackStkO PROTO((P_ stko, W_ *size)); P_ AllocateHeap PROTO((W_ size)); /* Doesn't belong */ -P_ get_closure_info PROTO((P_ closure, W_ *size, W_ *ptrs, W_ *nonptrs, W_ *vhs)); - -rtsBool isOffset PROTO((globalAddr *ga)), - isFixed PROTO((globalAddr *ga)); - void InitClosureQueue (STG_NO_ARGS); P_ DeQueueClosure(STG_NO_ARGS); void QueueClosure PROTO((P_ closure)); rtsBool QueueEmpty(STG_NO_ARGS); void PrintPacket PROTO((P_ buffer)); -void doGlobalGC(STG_NO_ARGS); -P_ UnpackGraph PROTO((W_ *buffer, globalAddr **gamap, W_ *nGAs)); -# endif +P_ get_closure_info PROTO((P_ closure, W_ *size, W_ *ptrs, W_ *nonptrs, W_ *vhs, char *type)); + +rtsBool isOffset PROTO((globalAddr *ga)), + isFixed PROTO((globalAddr *ga)); +void doGlobalGC(STG_NO_ARGS); + +P_ PackNearbyGraph PROTO((P_ closure,W_ *size)); +P_ UnpackGraph PROTO((W_ *buffer, globalAddr **gamap, W_ *nGAs)); \end{code} \begin{code} -# define PACK_HEAP_REQUIRED \ - ((RTSflags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 2)) +# define PACK_HEAP_REQUIRED \ + ((RTSflags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 2)) extern W_ *PackBuffer; /* size: can be set via option */ extern long *buffer; /* HWL_ */ @@ -518,12 +509,55 @@ extern void AllocClosureQueue(W_ size); # define PACK_HDR_SIZE 1 /* Words of header in a packet */ # define PACK_PLC_SIZE 2 /* Size of a packed PLC in words */ - + +#endif \end{code} -End multi-slurp protection: \begin{code} -# endif /* yes, it is PARallel */ -#endif /* it was GRAN or PARallel */ + +#if defined(GRAN) +/* ToDo: Check which of the PAR routines are needed in GranSim -- HWL */ +void InitPackBuffer(STG_NO_ARGS); +P_ AllocateHeap PROTO((W_ size)); /* Doesn't belong */ +P_ PackNearbyGraph PROTO((P_ closure, P_ tso, W_ *packbuffersize)); +P_ PackOneNode PROTO((P_ closure, P_ tso, W_ *packbuffersize)); +P_ UnpackGraph PROTO((P_ buffer)); + +void InitClosureQueue (STG_NO_ARGS); +P_ DeQueueClosure(STG_NO_ARGS); +void QueueClosure PROTO((P_ closure)); +rtsBool QueueEmpty(STG_NO_ARGS); +void PrintPacket PROTO((P_ buffer)); + +P_ get_closure_info PROTO((P_ closure, W_ *size, W_ *ptrs, W_ *nonptrs, W_ *vhs, char *type)); + +/* These are needed in the packing code to get the size of the packet + right. The closures itself are never built in GrAnSim. */ +# define FETCHME_VHS IND_VHS +# define FETCHME_HS IND_HS + +# define FETCHME_GA_LOCN FETCHME_HS + +# define FETCHME_CLOSURE_SIZE(closure) IND_CLOSURE_SIZE(closure) +# define FETCHME_CLOSURE_NoPTRS(closure) 0L +# define FETCHME_CLOSURE_NoNONPTRS(closure) (IND_CLOSURE_SIZE(closure)-IND_VHS) + +# define MAX_GAS (RTSflags.GranFlags.packBufferSize / PACK_GA_SIZE) +# define PACK_GA_SIZE 3 /* Size of a packed GA in words */ + /* Size of a packed fetch-me in words */ +# define PACK_FETCHME_SIZE (PACK_GA_SIZE + FIXED_HS) +# define PACK_HDR_SIZE 4 /* Words of header in a packet */ + +# define PACK_HEAP_REQUIRED \ + ((RTSflags.GranFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 2)) + +# define PACK_FLAG_LOCN 0 +# define PACK_TSO_LOCN 1 +# define PACK_UNPACKED_SIZE_LOCN 2 +# define PACK_SIZE_LOCN 3 +# define MAGIC_PACK_FLAG 0xfabc +#endif #endif /* Parallel_H */ \end{code} + + diff --git a/ghc/includes/RtsFlags.lh b/ghc/includes/RtsFlags.lh index 9a7bbaa2ce..c7a8af93e9 100644 --- a/ghc/includes/RtsFlags.lh +++ b/ghc/includes/RtsFlags.lh @@ -31,14 +31,14 @@ struct GC_FLAGS { 2 set: details of minor collections 4 set: details of major collections, except marking 8 set: ditto, but marking this time - 16 set: GC of MallocPtrs + 16 set: GC of ForeignObjs 32 set: GC of Concurrent things */ -#define DEBUG_TRACE_MINOR_GC 2 -#define DEBUG_TRACE_MAJOR_GC 4 -#define DEBUG_TRACE_MARKING 8 -#define DEBUG_TRACE_MALLOCPTRS 16 -#define DEBUG_TRACE_CONCURRENT 32 +#define DEBUG_TRACE_MINOR_GC 2 +#define DEBUG_TRACE_MAJOR_GC 4 +#define DEBUG_TRACE_MARKING 8 +#define DEBUG_TRACE_FOREIGNOBJS 16 +#define DEBUG_TRACE_CONCURRENT 32 rtsBool lazyBlackHoling; rtsBool doSelectorsAtGC; @@ -86,6 +86,13 @@ struct PROFILING_FLAGS { # define DESCRchar 'D' # define TYPEchar 'Y' # define TIMEchar 'T' + + char *ccSelector; + char *modSelector; + char *grpSelector; + char *descrSelector; + char *typeSelector; + char *kindSelector; }; #endif @@ -113,6 +120,83 @@ struct PAR_FLAGS { #ifdef GRAN struct GRAN_FLAGS { + rtsBool granSimStats; /* Full .gr profile (rtsTrue) or only END events? */ + rtsBool granSimStats_suppressed; /* No .gr profile at all */ + rtsBool granSimStats_Binary; + rtsBool granSimStats_Sparks; + rtsBool granSimStats_Heap; + rtsBool labelling; + W_ packBufferSize; + W_ packBufferSize_internal; + + I_ proc; /* number of processors */ + I_ max_fishes; /* max number of spark or thread steals */ + TIME time_slice; /* max time slice of one reduction thread */ + + /* Communication Cost Variables -- set in main program */ + W_ gran_latency; /* Latency for single packet */ + W_ gran_additional_latency; /* Latency for additional packets */ + W_ gran_fetchtime; + W_ gran_lunblocktime; /* Time for local unblock */ + W_ gran_gunblocktime; /* Time for global unblock */ + W_ gran_mpacktime; /* Cost of creating a packet */ + W_ gran_munpacktime; /* Cost of receiving a packet */ + W_ gran_mtidytime; /* Cost of cleaning up after send */ + + W_ gran_threadcreatetime; /* Thread creation costs */ + W_ gran_threadqueuetime; /* Cost of adding a thread to the running/runnable queue */ + W_ gran_threaddescheduletime; /* Cost of descheduling a thread */ + W_ gran_threadscheduletime; /* Cost of scheduling a thread */ + W_ gran_threadcontextswitchtime; /* Cost of context switch */ + + /* Instruction Costs */ + W_ gran_arith_cost; /* arithmetic instructions (+,i,< etc) */ + W_ gran_branch_cost; /* branch instructions */ + W_ gran_load_cost; /* load into register */ + W_ gran_store_cost; /* store into memory */ + W_ gran_float_cost; /* floating point operations */ + + W_ gran_heapalloc_cost; /* heap allocation costs */ + + /* Overhead for granularity control mechanisms */ + /* overhead per elem of spark queue */ + W_ gran_pri_spark_overhead; + /* overhead per elem of thread queue */ + W_ gran_pri_sched_overhead; + + /* GrAnSim-Light: This version puts no bound on the number of + processors but in exchange doesn't model communication costs + (all communication is 0 cost). Mainly intended to show maximal + degree of parallelism in the program (*not* to simulate the + execution on a real machine). */ + + rtsBool Light; + + rtsBool DoFairSchedule ; /* fair scheduling alg? default: unfair */ + rtsBool DoReScheduleOnFetch ; /* async. communication? */ + rtsBool DoStealThreadsFirst; /* prefer threads over sparks when stealing */ + rtsBool SimplifiedFetch; /* fast but inaccurate fetch modelling */ + rtsBool DoAlwaysCreateThreads; /* eager thread creation */ + rtsBool DoGUMMFetching; /* bulk fetching */ + rtsBool DoThreadMigration; /* allow to move threads */ + I_ FetchStrategy; /* what to do when waiting for data */ + rtsBool PreferSparksOfLocalNodes; /* prefer local over global sparks */ + rtsBool DoPrioritySparking; /* sparks sorted by priorities */ + rtsBool DoPriorityScheduling; /* threads sorted by priorities */ + I_ SparkPriority; /* threshold for cut-off mechanism */ + I_ SparkPriority2; + rtsBool RandomPriorities; + rtsBool InversePriorities; + rtsBool IgnorePriorities; + I_ ThunksToPack; /* number of thunks in packet + 1 */ + rtsBool RandomSteal; /* steal spark/thread from random proc */ + rtsBool NoForward; /* no forwarding of fetch messages */ + rtsBool PrintFetchMisses; /* print number of fetch misses */ + + W_ debug; + rtsBool event_trace; + rtsBool event_trace_all; + }; #endif /* GRAN */ diff --git a/ghc/includes/RtsTypes.lh b/ghc/includes/RtsTypes.lh index a72694c17d..7e226520be 100644 --- a/ghc/includes/RtsTypes.lh +++ b/ghc/includes/RtsTypes.lh @@ -70,43 +70,6 @@ typedef W_ TIME; typedef GLOBAL_TASK_ID PROC; #endif -#if defined(GRAN) || defined(PAR) -/* Granularity event types for output */ -enum gran_event_types { - GR_START = 0, GR_STARTQ, - GR_STEALING, GR_STOLEN, GR_STOLENQ, - GR_FETCH, GR_REPLY, GR_BLOCK, GR_RESUME, GR_RESUMEQ, - GR_SCHEDULE, GR_DESCHEDULE, - GR_END, - SP_SPARK, SP_SPARKAT, SP_USED, SP_PRUNED, SP_EXPORTED, SP_ACQUIRED, - GR_TERMINATE, - GR_EVENT_MAX -}; - -#endif - -#ifdef GRAN - -typedef struct spark -{ - struct spark *prev, *next; - P_ node; - I_ name, global; -} *sparkq; - -typedef struct event { - PROC proc; /* Processor id */ - PROC creator; /* Processor id of PE that created the event */ - EVTTYPE evttype; /* Event type */ - TIME time; /* Time at which event happened */ - P_ tso; /* Associated TSO, if relevant, Nil_closure otherwise*/ - P_ node; /* Associated node, if relevant, Nil_closure otherwise*/ - sparkq spark; /* Associated SPARK, if relevant, NULL otherwise */ - struct event *next; - } *eventq; - -#endif - \end{code} A cost centre is represented by a pointer to a static structure @@ -124,24 +87,32 @@ typedef struct cc { char *module; /* name of module in which _scc_ occurs */ char *group; /* name of group in which _scc_ occurs */ - char is_subsumed; /* '\0' => *not* a CAF or dict cc */ - /* 'C' => *is* a CAF cc */ - /* 'D' => *is* a dictionary cc */ + char is_subsumed; /* 'B' => *not* a CAF/dict/sub cc */ + /* 'S' => *is* a subsumed cc */ + /* 'c' => *is* a CAF cc */ + /* 'd' => *is* a dictionary cc */ + /* IS_CAF_OR_DICT tests for lowercase bit */ /* Statistics Gathered */ W_ scc_count; /* no of scc expression instantiations */ W_ sub_scc_count; /* no of scc's set inside this cc */ - W_ cafcc_count; /* no of scc expression instantiations */ W_ sub_cafcc_count; /* no of scc's set inside this cc */ + W_ sub_dictcc_count; /* no of scc's set inside this cc */ +#if defined(PROFILING_DETAIL_COUNTS) W_ thunk_count; /* no of {thunk,function,PAP} enters */ W_ function_count; /* in this cost centre */ W_ pap_count; + W_ mem_allocs; /* no of allocations */ + + W_ subsumed_fun_count; /* no of functions subsumed */ + W_ subsumed_caf_count; /* no of caf/dict funs subsumed */ + W_ caffun_subsumed; /* no of subsumes from this caf/dict */ +#endif W_ time_ticks; /* no of timer interrupts -- current interval */ W_ prev_ticks; /* no of timer interrupts -- previous intervals */ - W_ mem_allocs; /* no of allocations */ W_ mem_alloc; /* no of words allocated (excl CC_HDR) */ /* Heap Profiling by Cost Centre */ @@ -150,6 +121,12 @@ typedef struct cc { } *CostCentre; +#if defined(PROFILING_DETAIL_COUNTS) +#define INIT_CC_STATS 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +#else +#define INIT_CC_STATS 0,0,0,0,0,0,0,0 +#endif + #endif /* defined(PROFILING) || defined(CONCURRENT) */ \end{code} diff --git a/ghc/includes/SMClosures.lh b/ghc/includes/SMClosures.lh index 326eaf3176..fc20664718 100644 --- a/ghc/includes/SMClosures.lh +++ b/ghc/includes/SMClosures.lh @@ -506,71 +506,75 @@ they will hear about it soon enough (WDP 95/05). %************************************************************************ %* * -\subsubsection[MallocPtr-closures]{@MallocPtr@ closure macros} +\subsubsection[ForeignObj-closures]{@ForeignObj@ closure macros} %* * %************************************************************************ -Here's what a MallocPtr looks like: +Here's what a ForeignObj looks like: \begin{verbatim} <Var Hdr> -+----------+----------+------+------+ -| Info Ptr | Forward | Data | List | -+----------+----------+------+------+ ++----------+----------+------+-------------+------+ +| Info Ptr | Forward | Data | FreeRoutine | List | ++----------+----------+------+-------------+------+ \end{verbatim} -The list is a pointer to the next MallocPtr in the list of all -MallocPtrs. Note that it is essential that the garbage collector {\em +@List@ is a pointer to the next ForeignObj in the list of all +ForeignObjs. Note that it is essential that the garbage collector {\em not\/} follow this link but that the link must get updated with the new address. The optional @Forward@ field is used by copying collectors to insert the forwarding pointer into. (If we overwrite the @Data@ part, we -don't know which MallocPtr has just died; if we overwrite the @List@ part, -we can't traverse the list of all MallocPtrs.) +don't know which ForeignObj has just died; if we overwrite the @List@ part, +we can't traverse the list of all ForeignObjs.) + +The @FreeRoutine@ is a reference to the finalisation routine to call +when the @ForeignObj@ becomes garbage -- SOF 4/96 \begin{code} #if !defined(PAR) # if defined(_INFO_COPYING) -# define MallocPtr_VHS 1 +# define ForeignObj_VHS 1 # else -# define MallocPtr_VHS 0 +# define ForeignObj_VHS 0 # endif -# define MallocPtr_HS (FIXED_HS + MallocPtr_VHS) -# define MallocPtr_SIZE (MallocPtr_VHS + 2) +# define ForeignObj_HS (FIXED_HS + ForeignObj_VHS) +# define ForeignObj_SIZE (ForeignObj_VHS + 3) -# define MallocPtr_CLOSURE_NoPTRS(closure) 0 -# define MallocPtr_CLOSURE_DATA(closure) (((StgMallocPtr *)(closure))[MallocPtr_HS + 0]) -# define MallocPtr_CLOSURE_LINK(closure) (((StgPtrPtr) (closure))[MallocPtr_HS + 1]) +# define ForeignObj_CLOSURE_NoPTRS(closure) 0 +# define ForeignObj_CLOSURE_DATA(closure) (((StgForeignObj *)(closure))[ForeignObj_HS + 0]) +# define ForeignObj_CLOSURE_FINALISER(closure) (((StgForeignObj *)(closure))[ForeignObj_HS + 1]) +# define ForeignObj_CLOSURE_LINK(closure) (((StgPtrPtr) (closure))[ForeignObj_HS + 2]) -# define SET_MallocPtr_HDR(closure,infolbl,cc,size,ptrs) \ +# define SET_ForeignObj_HDR(closure,infolbl,cc,size,ptrs) \ SET_FIXED_HDR(closure,infolbl,cc) \end{code} -And to check that a Malloc ptr closure is valid +And to check that a Foreign ptr closure is valid \begin{code} -EXTDATA_RO(MallocPtr_info); +EXTDATA_RO(ForeignObj_info); # if defined(DEBUG) -# define CHECK_MallocPtr_CLOSURE( closure ) \ +# define CHECK_ForeignObj_CLOSURE( closure ) \ do { \ - CHECK_MallocPtr_InfoTable( closure ); \ + CHECK_ForeignObj_InfoTable( closure ); \ } while (0) -# define CHECK_MallocPtr_InfoTable( closure ) \ - ASSERT( (*((PP_)(closure))) == MallocPtr_info ) +# define CHECK_ForeignObj_InfoTable( closure ) \ + ASSERT( (*((PP_)(closure))) == ForeignObj_info ) -extern void Validate_MallocPtrList( P_ MPlist ); -# define VALIDATE_MallocPtrList( mplist ) Validate_MallocPtrList( mplist ) +extern void Validate_ForeignObjList( P_ MPlist ); +# define VALIDATE_ForeignObjList( mplist ) Validate_ForeignObjList( mplist ) # else /* !DEBUG */ -# define CHECK_MallocPtr_CLOSURE( closure ) /* nothing */ -# define VALIDATE_MallocPtrList( mplist ) /* nothing */ +# define CHECK_ForeignObj_CLOSURE( closure ) /* nothing */ +# define VALIDATE_ForeignObjList( mplist ) /* nothing */ # endif /* !DEBUG */ #endif /* !PAR */ @@ -812,8 +816,8 @@ variable header): #define DATA_CLOSURE_NoPTRS(closure) ((I_)0) #define DATA_CLOSURE_NoNONPTRS(closure) (DATA_CLOSURE_SIZE(closure) - DATA_VHS) -#define SET_DATA_HDR(closure,infolbl,cc,size,ptrs/*==0*/) \ - { SET_FIXED_HDR(closure,infolbl,cc); \ +#define SET_DATA_HDR(closure,infolbl,cc,size,ptrs) \ + { SET_FIXED_HDR(closure,infolbl,cc); \ DATA_CLOSURE_SIZE(closure) = (W_)(size); } \end{code} diff --git a/ghc/includes/SMInfoTables.lh b/ghc/includes/SMInfoTables.lh index 5cbbf0687e..071bce332e 100644 --- a/ghc/includes/SMInfoTables.lh +++ b/ghc/includes/SMInfoTables.lh @@ -96,8 +96,8 @@ It can have the following values (defined in CostCentre.lh): A black hole. \item[@ARR_K@] An array. - \item[@MP_K@] - A Malloc Pointer. + \item[@ForeignObj_K@] + A Foreign object (non-Haskell heap resident). \item[@SPT_K@] The Stable Pointer table. (There should only be one of these but it represents a form of weak space leak since it can't shrink to meet @@ -336,7 +336,7 @@ Otherwise, we add the RBH info table pointer to the end of the normal info table and vice versa. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) # define RBH_INFO_OFFSET (GEN_INFO_OFFSET+GEN_INFO_WORDS) # define INCLUDE_SPEC_PADDING \ @@ -363,8 +363,13 @@ info table and vice versa. EXTFUN(RBH_entry); P_ convertToRBH PROTO((P_ closure)); +#if defined(GRAN) +void convertFromRBH PROTO((P_ closure)); +#elif defined(PAR) void convertToFetchMe PROTO((P_ closure, globalAddr *ga)); #endif + +#endif \end{code} %************************************************************************ @@ -711,7 +716,7 @@ MAYBE_DECLARE_RTBL(Spec_S,12,12) CAT2(_ScanMove_,size),CAT2(_PRIn_,ptrs)) \ } -#ifdef PAR +#if defined(PAR) || defined(GRAN) # define SPEC_U_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \ entry_localness(CAT2(RBH_,entry_code)); \ localness W_ infolbl[]; \ @@ -873,7 +878,7 @@ Compacting: only the PRStart (marking) routine needs to be special. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) # define SELECT_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,select_word_i,kind,descr,type) \ entry_localness(CAT2(RBH_,entry_code)); \ localness W_ infolbl[]; \ @@ -1000,7 +1005,7 @@ MAYBE_DECLARE_RTBL(Gen_S,,) INCLUDE_COMPACTING_INFO(_ScanLink_S_N,_PRStart_N,_ScanMove_S,_PRIn_I) \ } -#ifdef PAR +#if defined(PAR) || defined(GRAN) # define GEN_U_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \ entry_localness(CAT2(RBH_,entry_code)); \ localness W_ infolbl[]; \ @@ -1274,7 +1279,7 @@ MAYBE_DECLARE_RTBL(Static,,) %************************************************************************ %* * -\subsection[MallocPtr_ITBL]{@MallocPtr_TBL@: @MallocPtr@ info-table} +\subsection[ForeignObj_ITBL]{@ForeignObj_TBL@: @ForeignObj@ info-table} %* * %************************************************************************ @@ -1287,25 +1292,25 @@ I'm assuming @SPEC_N@, so that we don't need to pad out the info table. (JSM) \begin{code} #if !defined(PAR) -# define MallocPtr_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*size,ptrs unused*/ \ +# define ForeignObj_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*size,ptrs unused*/ \ CAT_DECLARE(infolbl,kind,descr,type) \ entry_localness(entry_code); \ localness W_ infolbl[] = { \ (W_) entry_code \ ,(W_) tag \ - ,(W_) MK_REP_REF(MallocPtr,,) \ + ,(W_) MK_REP_REF(ForeignObj,,) \ INCLUDE_PROFILING_INFO(infolbl) \ } -MAYBE_DECLARE_RTBL(MallocPtr,,) +MAYBE_DECLARE_RTBL(ForeignObj,,) -# define MallocPtr_RTBL() \ - const W_ MK_REP_LBL(MallocPtr,,)[] = { \ +# define ForeignObj_RTBL() \ + const W_ MK_REP_LBL(ForeignObj,,)[] = { \ INCLUDE_TYPE_INFO(INTERNAL) \ - INCLUDE_SIZE_INFO(MallocPtr_SIZE, 0L) \ + INCLUDE_SIZE_INFO(ForeignObj_SIZE, 0L) \ INCLUDE_PAR_INFO \ - INCLUDE_COPYING_INFO(_Evacuate_MallocPtr,_Scavenge_MallocPtr) \ - SPEC_COMPACTING_INFO(_ScanLink_MallocPtr,_PRStart_MallocPtr,_ScanMove_MallocPtr,_PRIn_0) \ + INCLUDE_COPYING_INFO(_Evacuate_ForeignObj,_Scavenge_ForeignObj) \ + SPEC_COMPACTING_INFO(_ScanLink_ForeignObj,_PRStart_ForeignObj,_ScanMove_ForeignObj,_PRIn_0) \ } #endif /* !PAR */ @@ -1737,7 +1742,7 @@ during a return. /* Declare the phantom info table vectors (just Bool at the moment) */ #ifndef COMPILING_GHC -EXTDATA_RO(Bool_itblvtbl); +EXTDATA_RO(Prelude_Bool_itblvtbl); #endif \end{code} diff --git a/ghc/includes/SMcompact.lh b/ghc/includes/SMcompact.lh index 9fb25d819b..c491b5b995 100644 --- a/ghc/includes/SMcompact.lh +++ b/ghc/includes/SMcompact.lh @@ -85,7 +85,7 @@ extern StgScanFun _ScanLink_MuTuple; extern StgScanFun _ScanLink_PI; #endif -#ifdef PAR +#if defined(PAR) || defined(GRAN) extern StgScanFun _ScanLink_RBH_2_1; extern StgScanFun _ScanLink_RBH_3_1; extern StgScanFun _ScanLink_RBH_3_3; @@ -117,10 +117,11 @@ extern StgScanFun _ScanMove_RBH_11; extern StgScanFun _ScanMove_RBH_12; extern StgScanFun _ScanMove_RBH_S; +#endif /* PAR || GRAN */ -#else -extern StgScanFun _ScanLink_MallocPtr; -#endif /* PAR */ +#if !defined(PAR) || defined(GRAN) +extern StgScanFun _ScanLink_ForeignObj; +#endif extern StgScanFun _ScanLink_BH_N; extern StgScanFun _ScanLink_BH_U; @@ -158,7 +159,7 @@ extern StgScanFun _ScanMove_PI; #endif #ifndef PAR -extern StgScanFun _ScanMove_MallocPtr; +extern StgScanFun _ScanMove_ForeignObj; #endif /* !PAR */ extern StgScanFun _ScanMove_ImmuTuple; diff --git a/ghc/includes/SMcopying.lh b/ghc/includes/SMcopying.lh index 252fbfca9c..7667fb2d4b 100644 --- a/ghc/includes/SMcopying.lh +++ b/ghc/includes/SMcopying.lh @@ -84,7 +84,7 @@ extern StgScavFun _Scavenge_Data; extern StgEvacFun _Evacuate_MuTuple; extern StgScavFun _Scavenge_MuTuple; -#ifdef PAR +#if defined(PAR) || defined(GRAN) extern StgEvacFun _Evacuate_RBH_2; extern StgEvacFun _Evacuate_RBH_3; extern StgEvacFun _Evacuate_RBH_4; @@ -117,11 +117,14 @@ extern StgScavFun _Scavenge_RBH_12_12; extern StgScavFun _Scavenge_RBH_N; extern StgScavFun _Scavenge_FetchMe; extern StgScavFun _Scavenge_BF; -#else -extern StgEvacFun _Evacuate_MallocPtr; -extern StgScavFun _Scavenge_MallocPtr; +#endif /* PAR || GRAN */ + +#if !defined(PAR) || defined(GRAN) +extern StgEvacFun _Evacuate_ForeignObj; +extern StgScavFun _Scavenge_ForeignObj; #endif /* PAR */ + extern StgEvacFun _Evacuate_BH_N; extern StgScavFun _Scavenge_BH_N; diff --git a/ghc/includes/SMinterface.lh b/ghc/includes/SMinterface.lh index 30699895f7..6b272869b5 100644 --- a/ghc/includes/SMinterface.lh +++ b/ghc/includes/SMinterface.lh @@ -54,10 +54,10 @@ typedef struct { #endif #ifndef PAR - P_ MallocPtrList; /* List of all Malloc Pointers (in new generation) */ + P_ ForeignObjList; /* List of all Foreign objects (in new generation) */ #if defined(GCap) || defined(GCgn) - P_ OldMallocPtrList; /* List of all Malloc Pointers in old generation */ + P_ OldForeignObjList; /* List of all Foreign objects in old generation */ #endif P_ StablePointerTable; @@ -82,9 +82,8 @@ Answer: They're on the heap in a "Stable Pointer Table". (ADR) #else # ifndef PAR # ifdef GRAN -# define SM_MAXROOTS (10 + (MAX_PROC*4) + 2 + (MAX_PROC*2) + MAX_SPARKS) - /* unthreaded + spark/thread queues + Current/Main TSOs - + events + sparks */ +# define SM_MAXROOTS (10 + (MAX_PROC*2) + 2 ) + /* unthreaded + hd/tl thread queues + Current/Main TSOs */ # else # define SM_MAXROOTS 5 /* See c-as-asm/HpOverflow.lc */ # endif @@ -150,7 +149,7 @@ roots. If we are using Appel's collector it also initialises the @OldLim@ field. In the sequential system, it also initialises the stable pointer table -and the @MallocPtr@ (and @OldMallocPtrList@) fields. +and the @ForeignObjList@ (and @OldForeignObjList@) fields. @collectHeap@ invokes the garbage collector that was requested at compile time. @reqsize@ is the size of the request (in words) that @@ -197,9 +196,9 @@ B stack arising from any update frame ``squeezing'' [sequential only]. \item The elements of @CAFlist@ and the stable pointers will be updated to point to the new locations of the closures they reference. -\item Any members of @MallocPtrList@ which became garbage should have -been reported (by calling @FreeMallocPtr@; and the @(Old)MallocPtrList@ -updated to contain only those Malloc Pointers which are still live. +\item Any members of @ForeignObjList@ which became garbage should have +been reported (by calling their finalising routines; and the @(Old)ForeignObjList@ +updated to contain only those Foreign objects which are still live. \end{itemize} \end{description} @@ -433,7 +432,7 @@ same, but without the saved SuA pointer. We store the following information concerning the stacks in a global structure. (sequential only). \begin{code} -#ifndef CONCURRENT +#if 1 /* ndef CONCURRENT * /? HWL */ typedef struct { PP_ botA; /* Points to bottom-most word of A stack */ @@ -470,7 +469,7 @@ in the info-table. #define _INFO_MARKING #else -/* NO_INFO_SPECIFIED (ToDo: an #error ???) */ +/* NO_INFO_SPECIFIED (ToDo: an #error ?) */ #endif #endif #endif diff --git a/ghc/includes/SMmark.lh b/ghc/includes/SMmark.lh index 2c6cb0b31e..764f418e97 100644 --- a/ghc/includes/SMmark.lh +++ b/ghc/includes/SMmark.lh @@ -49,7 +49,7 @@ extern F_ _PRStart_MuTuple(STG_NO_ARGS); extern F_ _PRStart_PI(STG_NO_ARGS); #endif -#ifdef PAR +#if defined(PAR) || defined(GRAN) extern F_ _PRStart_RBH_0(STG_NO_ARGS); extern F_ _PRStart_RBH_1(STG_NO_ARGS); extern F_ _PRStart_RBH_2(STG_NO_ARGS); @@ -66,9 +66,11 @@ extern F_ _PRStart_RBH_12(STG_NO_ARGS); extern F_ _PRStart_RBH_N(STG_NO_ARGS); extern F_ _PRStart_FetchMe(STG_NO_ARGS); extern F_ _PRStart_BF(STG_NO_ARGS); -#else -extern F_ _PRStart_MallocPtr(STG_NO_ARGS); -#endif /* PAR */ +#endif /* PAR || GRAN */ + +#if !defined(PAR) || defined(GRAN) +extern F_ _PRStart_ForeignObj(STG_NO_ARGS); +#endif #if defined(CONCURRENT) extern F_ _PRStart_StkO(STG_NO_ARGS); @@ -117,7 +119,7 @@ extern F_ _PRIn_I_Dyn(STG_NO_ARGS); extern F_ _PRIn_I_Tuple(STG_NO_ARGS); extern F_ _PRIn_I_MuTuple(STG_NO_ARGS); -#ifdef PAR +#if defined(PAR) || defined(GRAN) extern F_ _PRIn_BF(STG_NO_ARGS); extern F_ _PRIn_RBH_0(STG_NO_ARGS); extern F_ _PRIn_RBH_1(STG_NO_ARGS); @@ -133,9 +135,11 @@ extern F_ _PRIn_RBH_10(STG_NO_ARGS); extern F_ _PRIn_RBH_11(STG_NO_ARGS); extern F_ _PRIn_RBH_12(STG_NO_ARGS); extern F_ _PRIn_RBH_I(STG_NO_ARGS); -#else -extern F_ _PRIn_I_MallocPtr(STG_NO_ARGS); -#endif /* PAR */ +#endif /* PAR || GRAN */ + +#if !defined(PAR) || defined(GRAN) +extern F_ _PRIn_I_ForeignObj(STG_NO_ARGS); +#endif extern F_ _PRIn_Error(STG_NO_ARGS); diff --git a/ghc/includes/SMupdate.lh b/ghc/includes/SMupdate.lh index 7da6a10006..de1d35ccde 100644 --- a/ghc/includes/SMupdate.lh +++ b/ghc/includes/SMupdate.lh @@ -348,7 +348,7 @@ EXTFUN(UpdatePAP); (IS_MUTABLE(INFO_PTR(closure)) && MUT_LINK(closure) != MUT_NOT_LINKED) # if defined(GRAN) -extern I_ AwakenBlockingQueue PROTO((P_)); +extern P_ AwakenBlockingQueue PROTO((P_)); # else extern void AwakenBlockingQueue PROTO((P_)); # endif diff --git a/ghc/includes/StgMacros.lh b/ghc/includes/StgMacros.lh index 54352204f2..baefd8076d 100644 --- a/ghc/includes/StgMacros.lh +++ b/ghc/includes/StgMacros.lh @@ -54,7 +54,15 @@ Mere abbreviations: General things; note: general-but-``machine-dependent'' macros are given in \tr{StgMachDeps.lh}. \begin{code} -#define STG_MAX(a,b) (((a)>=(b)) ? (a) : (b)) +I_ STG_MAX PROTO((I_, I_)); /* GCC -Wall loves prototypes */ + +extern STG_INLINE +I_ +STG_MAX(I_ a, I_ b) { return((a >= b) ? a : b); } +/* NB: the naive #define macro version of STG_MAX + can lead to exponential CPP explosion, if you + have very-nested STG_MAXes. +*/ /* Macros to combine two short words into a single @@ -1012,10 +1020,10 @@ which uses these anyway.) #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__) -extern void ASSIGN_DBL PROTO((W_ [], StgDouble)); -extern StgDouble PK_DBL PROTO((W_ [])); -extern void ASSIGN_FLT PROTO((W_ [], StgFloat)); -extern StgFloat PK_FLT PROTO((W_ [])); +void ASSIGN_DBL PROTO((W_ [], StgDouble)); +StgDouble PK_DBL PROTO((W_ [])); +void ASSIGN_FLT PROTO((W_ [], StgFloat)); +StgFloat PK_FLT PROTO((W_ [])); #else /* yes, its __GNUC__ && we really want them */ @@ -1036,6 +1044,12 @@ extern StgFloat PK_FLT PROTO((W_ [])); #else /* ! sparc */ +/* (not very) forward prototype declarations */ +void ASSIGN_DBL PROTO((W_ [], StgDouble)); +StgDouble PK_DBL PROTO((W_ [])); +void ASSIGN_FLT PROTO((W_ [], StgFloat)); +StgFloat PK_FLT PROTO((W_ [])); + extern STG_INLINE void ASSIGN_DBL(W_ p_dest[], StgDouble src) @@ -1291,14 +1305,14 @@ void newArrZh_init PROTO((P_ result, I_ n, P_ init)); %************************************************************************ \begin{code} -ED_(Nil_closure); +ED_(Prelude_Z91Z93_closure); #define newSynchVarZh(r, hp) \ { \ ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \ CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */ \ SET_SVAR_HDR(hp,EmptySVar_info,CCC); \ - SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = Nil_closure; \ + SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = Prelude_Z91Z93_closure; \ r = hp; \ } \end{code} @@ -1311,17 +1325,17 @@ extern void Yield PROTO((W_)); #define takeMVarZh(r, liveness, node) \ { \ while (INFO_PTR(node) != (W_) FullSVar_info) { \ - if (SVAR_HEAD(node) == Nil_closure) \ + if (SVAR_HEAD(node) == Prelude_Z91Z93_closure) \ SVAR_HEAD(node) = CurrentTSO; \ else \ TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \ - TSO_LINK(CurrentTSO) = (P_) Nil_closure; \ + TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure; \ SVAR_TAIL(node) = CurrentTSO; \ DO_YIELD(liveness << 1); \ } \ SET_INFO_PTR(node, EmptySVar_info); \ r = SVAR_VALUE(node); \ - SVAR_VALUE(node) = Nil_closure; \ + SVAR_VALUE(node) = Prelude_Z91Z93_closure; \ } #else @@ -1336,7 +1350,7 @@ extern void Yield PROTO((W_)); } \ SET_INFO_PTR(node, EmptySVar_info); \ r = SVAR_VALUE(node); \ - SVAR_VALUE(node) = Nil_closure; \ + SVAR_VALUE(node) = Prelude_Z91Z93_closure; \ } #endif @@ -1364,18 +1378,18 @@ extern void Yield PROTO((W_)); SET_INFO_PTR(node, FullSVar_info); \ SVAR_VALUE(node) = value; \ tso = SVAR_HEAD(node); \ - if (tso != (P_) Nil_closure) { \ + if (tso != (P_) Prelude_Z91Z93_closure) { \ if (DO_QP_PROF) \ STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \ - if (ThreadQueueHd == Nil_closure) \ + if (ThreadQueueHd == Prelude_Z91Z93_closure) \ ThreadQueueHd = tso; \ else \ TSO_LINK(ThreadQueueTl) = tso; \ ThreadQueueTl = tso; \ SVAR_HEAD(node) = TSO_LINK(tso); \ - TSO_LINK(tso) = (P_) Nil_closure; \ - if(SVAR_HEAD(node) == (P_) Nil_closure) \ - SVAR_TAIL(node) = (P_) Nil_closure; \ + TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure; \ + if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure) \ + SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure; \ } \ } @@ -1393,18 +1407,18 @@ extern void Yield PROTO((W_)); SET_INFO_PTR(node, FullSVar_info); \ SVAR_VALUE(node) = value; \ tso = SVAR_HEAD(node); \ - if (tso != (P_) Nil_closure) { \ + if (tso != (P_) Prelude_Z91Z93_closure) { \ if (DO_QP_PROF) \ STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \ - if (RunnableThreadsHd == Nil_closure) \ + if (RunnableThreadsHd == Prelude_Z91Z93_closure) \ RunnableThreadsHd = tso; \ else \ TSO_LINK(RunnableThreadsTl) = tso; \ RunnableThreadsTl = tso; \ SVAR_HEAD(node) = TSO_LINK(tso); \ - TSO_LINK(tso) = (P_) Nil_closure; \ - if(SVAR_HEAD(node) == (P_) Nil_closure) \ - SVAR_TAIL(node) = (P_) Nil_closure; \ + TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure; \ + if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure) \ + SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure; \ } \ } @@ -1434,11 +1448,11 @@ extern void Yield PROTO((W_)); #define readIVarZh(r, liveness, node) \ { \ if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \ - if (SVAR_HEAD(node) == Nil_closure) \ + if (SVAR_HEAD(node) == Prelude_Z91Z93_closure) \ SVAR_HEAD(node) = CurrentTSO; \ else \ TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \ - TSO_LINK(CurrentTSO) = (P_) Nil_closure; \ + TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure; \ SVAR_TAIL(node) = CurrentTSO; \ DO_YIELD(liveness << 1); \ } \ @@ -1481,12 +1495,12 @@ extern void Yield PROTO((W_)); EXIT(EXIT_FAILURE); \ } \ tso = SVAR_HEAD(node); \ - if (tso != (P_) Nil_closure) { \ - if (ThreadQueueHd == Nil_closure) \ + if (tso != (P_) Prelude_Z91Z93_closure) { \ + if (ThreadQueueHd == Prelude_Z91Z93_closure) \ ThreadQueueHd = tso; \ else \ TSO_LINK(ThreadQueueTl) = tso; \ - while(TSO_LINK(tso) != Nil_closure) { \ + while(TSO_LINK(tso) != Prelude_Z91Z93_closure) { \ if (DO_QP_PROF) \ STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \ tso = TSO_LINK(tso); \ @@ -1513,12 +1527,12 @@ extern void Yield PROTO((W_)); EXIT(EXIT_FAILURE); \ } \ tso = SVAR_HEAD(node); \ - if (tso != (P_) Nil_closure) { \ - if (RunnableThreadsHd == Nil_closure) \ + if (tso != (P_) Prelude_Z91Z93_closure) { \ + if (RunnableThreadsHd == Prelude_Z91Z93_closure) \ RunnableThreadsHd = tso; \ else \ TSO_LINK(RunnableThreadsTl) = tso; \ - while(TSO_LINK(tso) != Nil_closure) { \ + while(TSO_LINK(tso) != Prelude_Z91Z93_closure) { \ if (DO_QP_PROF) \ STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \ tso = TSO_LINK(tso); \ @@ -1568,12 +1582,12 @@ extern void Yield PROTO((W_)); #define delayZh(liveness, us) \ { \ - if (WaitingThreadsTl == Nil_closure) \ + if (WaitingThreadsTl == Prelude_Z91Z93_closure) \ WaitingThreadsHd = CurrentTSO; \ else \ TSO_LINK(WaitingThreadsTl) = CurrentTSO; \ WaitingThreadsTl = CurrentTSO; \ - TSO_LINK(CurrentTSO) = Nil_closure; \ + TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \ TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \ DO_YIELD(liveness << 1); \ } @@ -1593,24 +1607,55 @@ extern void Yield PROTO((W_)); /* ToDo: something for GRAN */ -#define waitZh(liveness, fd) \ +#define waitReadZh(liveness, fd) \ { \ - if (WaitingThreadsTl == Nil_closure) \ + if (WaitingThreadsTl == Prelude_Z91Z93_closure) \ WaitingThreadsHd = CurrentTSO; \ else \ TSO_LINK(WaitingThreadsTl) = CurrentTSO; \ WaitingThreadsTl = CurrentTSO; \ - TSO_LINK(CurrentTSO) = Nil_closure; \ + TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \ TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \ DO_YIELD(liveness << 1); \ } #else -#define waitZh(liveness, fd) \ +#define waitReadZh(liveness, fd) \ + { \ + fflush(stdout); \ + fprintf(stderr, "waitRead#: unthreaded build.\n"); \ + EXIT(EXIT_FAILURE); \ + } + +#endif + +#ifdef CONCURRENT + +/* ToDo: something for GRAN */ + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif HAVE_SYS_TYPES_H */ + +#define waitWriteZh(liveness, fd) \ + { \ + if (WaitingThreadsTl == Prelude_Z91Z93_closure) \ + WaitingThreadsHd = CurrentTSO; \ + else \ + TSO_LINK(WaitingThreadsTl) = CurrentTSO; \ + WaitingThreadsTl = CurrentTSO; \ + TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \ + TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \ + DO_YIELD(liveness << 1); \ + } + +#else + +#define waitWriteZh(liveness, fd) \ { \ fflush(stdout); \ - fprintf(stderr, "wait#: unthreaded build.\n"); \ + fprintf(stderr, "waitWrite#: unthreaded build.\n"); \ EXIT(EXIT_FAILURE); \ } @@ -1806,6 +1851,7 @@ do { \ \ newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \ SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \ + CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \ stablePtr = newSP; \ } while (0) @@ -1864,53 +1910,100 @@ Anything with tag >= 0 is in WHNF, so we discard it. \begin{code} #ifdef CONCURRENT -ED_(Nil_closure); +ED_(Prelude_Z91Z93_closure); ED_(True_closure); #if defined(GRAN) -#define parZh(r,hp,node,rest) \ - PARZh(r,hp,node,rest,0,0) +#define parZh(r,node) \ + PARZh(r,node,1,0,0,0,0,0) + +#define parAtZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1) -#define parAtZh(r,hp,node,where,identifier,rest) \ - parATZh(r,hp,node,where,identifier,rest,1) +#define parAtAbsZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2) -#define parAtForNowZh(r,hp,node,where,identifier,rest) \ - parATZh(r,hp,node,where,identifier,rest,0) +#define parAtRelZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3) -#define parATZh(r,hp,node,where,identifier,rest,local) \ +#define parAtForNowZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0) + +#define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \ { \ sparkq result; \ if (SHOULD_SPARK(node)) { \ - result = NewSpark((P_)node,identifier,local); \ - SAFESTGCALL3(void,(W_),GranSimSparkAt,result,where,identifier); \ + SaveAllStgRegs(); \ + { sparkq result; \ + result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local); \ + if (local==2) { /* special case for parAtAbs */ \ + GranSimSparkAtAbs(result,(I_)where,identifier);\ + } else if (local==3) { /* special case for parAtRel */ \ + GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier); \ + } else { \ + GranSimSparkAt(result,where,identifier); \ + } \ + context_switch = 1; \ + } \ + RestoreAllStgRegs(); \ } else if (do_qp_prof) { \ I_ tid = threadId++; \ SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \ } \ - r = (rest); \ + r = 1; /* return code for successful spark -- HWL */ \ } -#define parLocalZh(r,hp,node,identifier,rest) \ - PARZh(r,hp,node,rest,identifier,1) +#define parLocalZh(r,node,identifier,gran_info,size_info,par_info,rest) \ + PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1) + +#define parGlobalZh(r,node,identifier,gran_info,size_info,par_info,rest) \ + PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0) -#define parGlobalZh(r,hp,node,identifier,rest) \ - PARZh(r,hp,node,rest,identifier,0) +#if 1 -#define PARZh(r,hp,node,rest,identifier,local) \ +#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \ +{ \ + if (SHOULD_SPARK(node)) { \ + SaveAllStgRegs(); \ + { sparkq result; \ + result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\ + add_to_spark_queue(result); \ + GranSimSpark(local,(P_)node); \ + context_switch = 1; \ + } \ + RestoreAllStgRegs(); \ + } else if (do_qp_prof) { \ + I_ tid = threadId++; \ + SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \ + } \ + r = 1; /* return code for successful spark -- HWL */ \ +} + +#else + +#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \ { \ sparkq result; \ if (SHOULD_SPARK(node)) { \ - result = NewSpark((P_)node,identifier,local); \ + result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\ ADD_TO_SPARK_QUEUE(result); \ SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node); \ - /* context_switch = 1; not needed any more -- HWL */ \ + /* context_switch = 1; not needed any more -- HWL */ \ } else if (do_qp_prof) { \ I_ tid = threadId++; \ SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \ } \ - r = (rest); \ + r = 1; /* return code for successful spark -- HWL */ \ } +#endif + +#define copyableZh(r,node) \ + /* copyable not yet implemented!! */ + +#define noFollowZh(r,node) \ + /* noFollow not yet implemented!! */ + #else /* !GRAN */ extern I_ required_thread_count; @@ -1958,6 +2051,7 @@ extern I_ required_thread_count; r = 1; /* Should not be necessary */ \ } +#endif /* GRAN */ \end{code} The following seq# code should only be used in unoptimized code. @@ -1979,8 +2073,8 @@ ED_RO_(vtbl_seq); #define seqZh(r,liveness,node) \ ({ \ __label__ cont; \ - STK_CHK(liveness,0,2,0,0,0,0); \ - SpB -= BREL(2); \ + /* STK_CHK(liveness,0,2,0,0,0,0); */ \ + /* SpB -= BREL(2); */ \ SpB[BREL(0)] = (W_) RetReg; \ SpB[BREL(1)] = (W_) &&cont; \ RetReg = (StgRetAddr) vtbl_seq; \ @@ -1992,23 +2086,27 @@ ED_RO_(vtbl_seq); r = 1; /* Should be unnecessary */ \ }) -#endif /* GRAN */ #endif /* CONCURRENT */ \end{code} %************************************************************************ %* * -\subsubsection[StgMacros-malloc-ptrs]{Malloc Pointers} +\subsubsection[StgMacros-foreign-objects]{Foreign Objects} %* * %************************************************************************ -This macro is used to construct a MallocPtr on the heap after a ccall. -Since MallocPtr's are like arrays in many ways, this is heavily based -on the stuff for arrays above. +[Based on previous MallocPtr comments -- SOF] + +This macro is used to construct a ForeignObj on the heap. What this does is plug the pointer (which will be in a local -variable), into a fresh heap object and then sets a result (which will -be a register) to point to the fresh heap object. +variable) together with its finalising/free routine, into a fresh heap +object and then sets a result (which will be a register) to point +to the fresh heap object. + +To accommodate per-object finalisation, augment the macro with a +finalisation routine argument. Nothing spectacular, just plug the +pointer to the routine into the ForeignObj -- SOF 4/96 Question: what's this "SET_ACTIVITY" stuff - should I be doing this too? (It's if you want to use the SPAT profiling tools to @@ -2016,42 +2114,45 @@ characterize program behavior by ``activity'' -- tail-calling, heap-checking, etc. -- see Ticky.lh. It is quite specialized. WDP 95/1) +(Swapped first two arguments to make it come into line with what appears +to be `standard' format, return register then liveness mask. -- SOF 4/96) + \begin{code} #ifndef PAR -StgInt eqMallocPtr PROTO((StgMallocPtr p1, StgMallocPtr p2)); -void FreeMallocPtr PROTO((StgMallocPtr mp)); +StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2)); -#define constructMallocPtr(liveness, r, mptr) \ -do { \ - P_ result; \ - \ - HEAP_CHK(liveness, _FHS + MallocPtr_SIZE,0); \ - CC_ALLOC(CCC,_FHS + MallocPtr_SIZE,MallocPtr_K); /* cc prof */ \ +#define makeForeignObjZh(r, liveness, mptr, finalise) \ +do { \ + P_ result; \ + \ + HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0); \ + CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */ \ \ - result = Hp + 1 - (_FHS + MallocPtr_SIZE); \ - SET_MallocPtr_HDR(result,MallocPtr_info,CCC,_FHS + MallocPtr_SIZE,0); \ - MallocPtr_CLOSURE_DATA(result) = mptr; \ - MallocPtr_CLOSURE_LINK(result) = StorageMgrInfo.MallocPtrList; \ - StorageMgrInfo.MallocPtrList = result; \ + result = Hp + 1 - (_FHS + ForeignObj_SIZE); \ + SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \ + ForeignObj_CLOSURE_DATA(result) = (P_)mptr; \ + ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise; \ + ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \ + StorageMgrInfo.ForeignObjList = result; \ \ /* \ - printf("DEBUG: MallocPtr(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \ + printf("DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \ result, \ result[0],result[1], \ result[2],result[3]); \ */ \ - CHECK_MallocPtr_CLOSURE( result ); \ - VALIDATE_MallocPtrList( StorageMgrInfo.MallocPtrList ); \ + CHECK_ForeignObj_CLOSURE( result ); \ + VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \ \ (r) = (P_) result; \ } while (0) #else -#define constructMallocPtr(liveness, r, mptr) \ +#define makeForeignObjZh(r, liveness, mptr, finalise) \ do { \ fflush(stdout); \ - fprintf(stderr, "constructMallocPtr: no malloc pointer support.\n");\ + fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\ EXIT(EXIT_FAILURE); \ } while(0) diff --git a/ghc/includes/StgTypes.lh b/ghc/includes/StgTypes.lh index 9a8dda1a9e..24783aedda 100644 --- a/ghc/includes/StgTypes.lh +++ b/ghc/includes/StgTypes.lh @@ -25,7 +25,7 @@ StgFloat & float \\ StgDouble & double \\ StgChar & unsigned char \\\hline StgStablePtr & long \\ -StgMallocPtr & (long *) \\ +StgForeignObj & (long *) \\ \end{tabular} %partain:\end{center} @@ -112,8 +112,8 @@ typedef StgChar *StgByteArray; typedef StgByteArray B_; typedef I_ StgStablePtr; /* Index into Stable Pointer Table */ -typedef P_ StgMallocPtr; /* (Probably) Pointer to object in C Heap */ -/* On any architecture, StgMallocPtr should be big enough to hold +typedef P_ StgForeignObj; /* (Probably) Pointer to object in C Heap */ +/* On any architecture, StgForeignObj should be big enough to hold the largest possible pointer. */ /* These are used to pass the do_full_collection flag to RealPerformGC diff --git a/ghc/includes/Threads.lh b/ghc/includes/Threads.lh index 7236d7d128..4b9a72201e 100644 --- a/ghc/includes/Threads.lh +++ b/ghc/includes/Threads.lh @@ -9,18 +9,23 @@ \end{code} \begin{code} -#ifndef GRAN -#define GRAN_ALLOC_HEAP(n,liveness) /* nothing */ -#define GRAN_UNALLOC_HEAP(n,liveness) /* nothing */ -#define GRAN_FETCH() /* nothing */ -#define GRAN_FETCH_AND_RESCHEDULE(liveness) /* nothing */ -#define GRAN_RESCHEDULE(liveness, reenter) /* nothing */ -#define GRAN_EXEC(arith,branch,loads,stores,floats) /* nothing */ -#define GRAN_SPARK() /* nothing */ -#endif -\end{code} +#if defined(GRAN) + +#define sparkq sparkq +#define TYPE_OF_SPARK struct spark +#define TYPE_OF_SPARK_PTR sparkq +#define SIZE_OF_SPARK (sizeof(TYPE_OF_SPARK)) + +typedef struct spark +{ + struct spark *prev, *next; + P_ node; + I_ name, global; + I_ gran_info; +} *sparkq; + +#endif -\begin{code} #ifndef CONCURRENT #define OR_CONTEXT_SWITCH @@ -54,10 +59,15 @@ extern I_ context_switch; /* Flag set by signal handler */ #define ADVISORY_POOL 1 #define SPARK_POOLS 2 -#ifndef GRAN +#if !defined(GRAN) -extern PP_ PendingSparksBase[SPARK_POOLS], PendingSparksLim[SPARK_POOLS]; -extern PP_ PendingSparksHd[SPARK_POOLS], PendingSparksTl[SPARK_POOLS]; +#define TYPE_OF_SPARK PP_ +#define SIZE_OF_SPARK (sizeof(TYPE_OF_SPARK)) + +extern TYPE_OF_SPARK PendingSparksBase[SPARK_POOLS], + PendingSparksLim[SPARK_POOLS]; +extern TYPE_OF_SPARK PendingSparksHd[SPARK_POOLS], + PendingSparksTl[SPARK_POOLS]; extern I_ SparkLimit[SPARK_POOLS]; @@ -70,7 +80,10 @@ IF_RTS(extern void AwaitEvent(I_);) #else /* GRAN */ -extern sparkq PendingSparksHd[][SPARK_POOLS], PendingSparksTl[][SPARK_POOLS]; +extern TYPE_OF_SPARK_PTR PendingSparksBase[][SPARK_POOLS], + PendingSparksLim[][SPARK_POOLS]; +extern TYPE_OF_SPARK_PTR PendingSparksHd[][SPARK_POOLS], + PendingSparksTl[][SPARK_POOLS]; extern P_ RunnableThreadsHd[], RunnableThreadsTl[], WaitThreadsHd[], WaitThreadsTl[]; @@ -85,7 +98,7 @@ extern P_ RunnableThreadsHd[], RunnableThreadsTl[], IF_RTS(extern void PruneSparks(STG_NO_ARGS);) -#ifdef GRAN +#if defined(GRAN) /* Codes that can be used as params for ReSchedule */ /* I distinguish them from the values 0/1 in the -UGRAN setup for security */ @@ -94,177 +107,23 @@ IF_RTS(extern void PruneSparks(STG_NO_ARGS);) #define SAME_THREAD 11 #define NEW_THREAD SAME_THREAD #define CHANGE_THREAD 13 +#define END_OF_WORLD 14 -#define MAX_PROC (BITS_IN(W_)) /* Maximum number of PEs that can be simulated */ -extern W_ max_proc; - -extern W_ IdleProcs, Idlers; - -extern unsigned CurrentProc; -extern W_ CurrentTime[]; extern W_ SparksAvail, SurplusThreads; -/* Processor numbers to bitmasks and vice-versa */ -#define MainProc 0 - -#define PE_NUMBER(n) (1l << (long)n) -#define ThisPE PE_NUMBER(CurrentProc) -#define MainPE PE_NUMBER(MainProc) - -#define IS_LOCAL_TO(ga,proc) ((1l << (long) proc) & ga) - -/* These constants should eventually be program parameters */ - -/* Communication Cost Model (EDS-like), max_proc > 2. */ - -#define LATENCY 1000 /* Latency for single packet */ -#define ADDITIONAL_LATENCY 100 /* Latency for additional packets */ -#define BASICBLOCKTIME 10 -#define FETCHTIME (LATENCY*2+MSGUNPACKTIME) -#define LOCALUNBLOCKTIME 10 -#define GLOBALUNBLOCKTIME (LATENCY+MSGUNPACKTIME) - -extern W_ gran_latency, gran_additional_latency, gran_fetchtime, - gran_lunblocktime, gran_gunblocktime; - -#define MSGPACKTIME 0 /* Cost of creating a packet */ -#define MSGUNPACKTIME 0 /* Cost of receiving a packet */ - -extern W_ gran_mpacktime, gran_mtidytime, gran_munpacktime; - -/* Thread cost model */ -#define THREADCREATETIME (25+THREADSCHEDULETIME) -#define THREADQUEUETIME 12 /* Cost of adding a thread to the running/runnable queue */ -#define THREADDESCHEDULETIME 75 /* Cost of descheduling a thread */ -#define THREADSCHEDULETIME 75 /* Cost of scheduling a thread */ -#define THREADCONTEXTSWITCHTIME (THREADDESCHEDULETIME+THREADSCHEDULETIME) - -extern W_ gran_threadcreatetime, gran_threadqueuetime, - gran_threadscheduletime, gran_threaddescheduletime, - gran_threadcontextswitchtime; - -/* Instruction Cost model (SPARC, including cache misses) */ -#define ARITH_COST 1 -#define BRANCH_COST 2 -#define LOAD_COST 4 -#define STORE_COST 4 -#define FLOAT_COST 1 /* ? */ - -extern W_ gran_arith_cost, gran_branch_cost, - gran_load_cost, gran_store_cost, gran_float_cost, - gran_heapalloc_cost; - -/* Miscellaneous Parameters */ -extern I_ DoFairSchedule; -extern I_ DoReScheduleOnFetch; -extern I_ SimplifiedFetch; -extern I_ DoStealThreadsFirst; -extern I_ DoAlwaysCreateThreads; -extern I_ DoThreadMigration; -extern I_ DoGUMMFetching; -extern I_ FetchStrategy; -extern I_ PreferSparksOfLocalNodes; -/* These come from debug options -bD? */ -extern I_ NoForward; -extern I_ PrintFetchMisses, fetch_misses; -#if defined(COUNT) -extern I_ nUPDs, nUPDs_old, nUPDs_new, nUPDs_BQ, nPAPs, BQ_lens; -#endif - -extern I_ no_gr_profile; -extern I_ do_sp_profile; - -extern I_ NeedToReSchedule; - -extern void GranSimAllocate PROTO((I_, P_, W_)); -extern void GranSimUnAllocate PROTO((I_, P_, W_)); -extern I_ GranSimFetch PROTO((P_)); -extern void GranSimExec PROTO((W_,W_,W_,W_,W_)); -extern void GranSimSpark PROTO((W_,P_)); -extern void GranSimBlock (STG_NO_ARGS); -extern void PerformReschedule PROTO((W_, W_)); - -#if 0 /* 'ngo Dochmey */ - -#define GRAN_ALLOC_HEAP(n,liveness) STGCALL3(void,(),GranSimAllocate,n,0,0) -#define GRAN_UNALLOC_HEAP(n,liveness) STGCALL3(void,(),GranSimUnallocate,n,0,0) - -#define GRAN_FETCH() STGCALL1(I_,(),GranSimFetch,Node) - -#define GRAN_FETCH_AND_RESCHEDULE(liveness_mask) \ - do { if(liveness_mask&LIVENESS_R1) \ - STGCALL1(I_,(),GranSimFetch,Node); \ - GRAN_RESCHEDULE(liveness_mask,1); \ - } while(0) - -#define GRAN_RESCHEDULE(liveness_mask,reenter) \ - STGCALL2_GC(void,(), \ - PerformReschedule,liveness_mask,reenter) - -#define THREAD_CONTEXT_SWITCH(liveness_mask,reenter) \ - do { \ - if (context_switch /* OR_INTERVAL_EXPIRED */) { \ - GRAN_RESCHEDULE(liveness_mask,reenter); \ - } }while(0) - -#define GRAN_EXEC(arith,branch,load,store,floats) \ - STGCALL5(void,(),GranSimExec,arith,branch,load,store,floats) - - -#else /* 1 */ /* chu' Dochmey */ - -#define GRAN_ALLOC_HEAP(n,liveness) \ - SaveAllStgRegs(); \ - GranSimAllocate(n,0,0); \ - RestoreAllStgRegs(); - -#define GRAN_UNALLOC_HEAP(n,liveness) \ - SaveAllStgRegs(); \ - GranSimUnallocate(n,0,0); \ - RestoreAllStgRegs(); - -#define GRAN_FETCH() \ - SaveAllStgRegs(); \ - GranSimFetch(Node); \ - RestoreAllStgRegs(); - -#define GRAN_FETCH_AND_RESCHEDULE(liveness_mask) \ - do { if(liveness_mask&LIVENESS_R1) \ - SaveAllStgRegs(); \ - GranSimFetch(Node); \ - RestoreAllStgRegs(); \ - GRAN_RESCHEDULE(liveness_mask,1); \ - } while(0) - -#define GRAN_RESCHEDULE(liveness_mask,reenter) \ - PerformReschedule_wrapper(liveness_mask,reenter) - -#define THREAD_CONTEXT_SWITCH(liveness_mask,reenter) \ - do { \ - if (context_switch /* OR_INTERVAL_EXPIRED */) { \ - GRAN_RESCHEDULE(liveness_mask,reenter); \ - } }while(0) - -#define GRAN_EXEC(arith,branch,load,store,floats) \ - SaveAllStgRegs(); \ - GranSimExec(arith,branch,load,store,floats); \ - RestoreAllStgRegs(); - -#endif - +extern W_ CurrentTime[]; +extern I_ OutstandingFetches[], OutstandingFishes[]; +extern enum proc_status procStatus[]; -#define ADD_TO_SPARK_QUEUE(spark) \ - SPARK_NEXT(spark) = NULL; \ - SPARK_PREV(spark) = PendingSparksTl[CurrentProc][ADVISORY_POOL]; \ - if (PendingSparksHd[CurrentProc][ADVISORY_POOL] == NULL) \ - PendingSparksHd[CurrentProc][ADVISORY_POOL] = spark; \ - else \ - SPARK_NEXT(PendingSparksTl[CurrentProc][ADVISORY_POOL]) = spark; \ - PendingSparksTl[CurrentProc][ADVISORY_POOL] = spark; \ +# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */ +# define FETCH_MASK_TSO 0x08000000 /* only bits 0, 1, 2 should be used */ + /* normally */ +extern P_ BlockedOnFetch[]; +# endif #endif /* GRAN */ -extern P_ CurrentTSO; /* thread state object now in use */ +extern P_ CurrentTSO; /* thread state object now in use */ extern P_ AvailableStack; extern P_ AvailableTSO; @@ -272,13 +131,29 @@ extern P_ AvailableTSO; extern I_ threadId; void ScheduleThreads PROTO((P_ topClosure)); + #if defined(GRAN) +#define OLD_SPARKNAME_MASK 0xffff0000 +#define NEW_SPARKNAME_MASK 0x0000ffff + void ReSchedule PROTO((int what_next)) STG_NORETURN; -#else +void add_to_spark_queue PROTO((sparkq)); +int set_sparkname PROTO((P_, int)); +int reset_sparkname PROTO((P_)); +I_ spark_queue_len PROTO((PROC, I_)); +sparkq delete_from_spark_queue PROTO((sparkq, sparkq)); +I_ thread_queue_len PROTO((PROC)); +void DisposeSparkQ PROTO((sparkq)); + +#else /* !GRAN */ + void ReSchedule PROTO((int again)) STG_NORETURN; + #endif + void EndThread(STG_NO_ARGS) STG_NORETURN; +/* ToDo: Check if these are still needed -- HWL */ void QP_Event0 PROTO((I_, P_)); void QP_Event1 PROTO((char *, P_)); void QP_Event2 PROTO((char *, P_, P_)); @@ -331,7 +206,8 @@ table for those values). #endif #if defined(GRAN) || defined(PAR) -#define TSO_GRAN_WORDS 15 + /* do we really need a whole statistics buffer in PAR setup? HWL*/ +#define TSO_GRAN_WORDS 17 #else #define TSO_GRAN_WORDS 0 #endif @@ -385,6 +261,8 @@ table for those values). #define TSO_GLOBALSPARKS_LOCN (TSO_GRAN_START + 12) #define TSO_LOCALSPARKS_LOCN (TSO_GRAN_START + 13) #define TSO_QUEUE_LOCN (TSO_GRAN_START + 14) +#define TSO_PRI_LOCN (TSO_GRAN_START + 15) +#define TSO_CLOCK_LOCN (TSO_GRAN_START + 16) #endif #define TSO_LINK(closure) (((PP_)closure)[TSO_LINK_LOCN]) @@ -416,6 +294,9 @@ table for those values). #define TSO_GLOBALSPARKS(closure) (((P_)closure)[TSO_GLOBALSPARKS_LOCN]) #define TSO_LOCALSPARKS(closure) (((P_)closure)[TSO_LOCALSPARKS_LOCN]) #define TSO_QUEUE(closure) (((P_)closure)[TSO_QUEUE_LOCN]) +#define TSO_PRI(closure) (((P_)closure)[TSO_PRI_LOCN]) +/* TSO_CLOCK is only needed in GrAnSim-Light */ +#define TSO_CLOCK(closure) (((P_)closure)[TSO_CLOCK_LOCN]) #define TSO_INTERNAL_PTR(closure) \ ((STGRegisterTable *)(((W_)(((P_)closure) \ @@ -451,6 +332,7 @@ Here are the various queues for GrAnSim-type events. #define Q_RUNNABLE 'A' #define Q_BLOCKED 'R' #define Q_FETCHING 'Y' +#define Q_MIGRATING 'B' \end{code} %************************************************************************ @@ -472,23 +354,33 @@ rtsBool Spark PROTO((P_ closure, rtsBool required)); #ifdef GRAN /* For GrAnSim sparks are currently mallocated -- HWL */ void DisposeSpark PROTO((sparkq spark)); +sparkq NewSpark PROTO((P_,I_,I_,I_,I_,I_)); + +/* # define MAX_EVENTS 1000 */ /* For GC Roots Purposes */ +# define MAX_SPARKS 0 /* i.e. infinite */ -# define MAX_SPARKS 2000 /* For GC Roots Purposes */ -# if defined(GRAN_TNG) -extern sparkq NewSpark PROTO((P_,I_,I_,I_)); -# else /* !GRAN_TNG */ -extern sparkq NewSpark PROTO((P_,I_,I_)); -# endif /* GRAN_TNG */ +#if defined(GRAN_JSM_SPARKS) +/* spark is a pointer into some sparkq (which is for JSM sparls just an + array of (struct sparks) */ +# define SPARK_PREV(spark) { fprintf(stderr,"Error: SPARK_PREV not supported for JSM sparks") \ + EXIT(EXIT_FAILURE); } +/* NB: SPARK_NEXT may only be used as a rhs but NOT as a lhs */ +# define SPARK_NEXT(spark) (spark++) +# define SPARK_NODE(spark) (P_)(spark->node) +# define SPARK_NAME(spark) (spark->name) +# define SPARK_GRAN_INFO(spark) (spark->gran_info) +# define SPARK_GLOBAL(spark) (spark->global) +# define SPARK_EXPORTED(spark) (SPARK_GLOBAL(spark) > 1) +#else # define SPARK_PREV(spark) (spark->prev) # define SPARK_NEXT(spark) (sparkq)(spark->next) -# define SPARK_NODE(spark) (P_)(spark->node) +# define SPARK_NODE(spark) (spark->node) # define SPARK_NAME(spark) (spark->name) -# if defined(GRAN_TNG) -# define SPARK_GRAN_INFO(spark) (spark->gran_info) -# endif /* GRAN_TNG */ +# define SPARK_GRAN_INFO(spark) (spark->gran_info) # define SPARK_GLOBAL(spark) (spark->global) # define SPARK_EXPORTED(spark) (SPARK_GLOBAL(spark) > 1) +#endif #endif /* GRAN */ \end{code} diff --git a/ghc/includes/config.h.in b/ghc/includes/config.h.in index 37bc54cc0a..3c4c68222a 100644 --- a/ghc/includes/config.h.in +++ b/ghc/includes/config.h.in @@ -150,7 +150,7 @@ /* Define if you have the <termios.h> header file. */ #undef HAVE_TERMIOS_H -/* Define if you have the <types.h> header file. */ +/* Define if you have the <time.h> header file. */ #undef HAVE_TIME_H /* Define if you have the <types.h> header file. */ diff --git a/ghc/includes/ghcSockets.h b/ghc/includes/ghcSockets.h index 5e7351f379..53152cbe05 100644 --- a/ghc/includes/ghcSockets.h +++ b/ghc/includes/ghcSockets.h @@ -16,4 +16,35 @@ #include <ctype.h> #include <unistd.h> +/* acceptSocket.lc */ +StgInt acceptSocket PROTO((StgInt, StgAddr, StgAddr)); + +/* bindSocket.lc */ +StgInt bindSocket PROTO((StgInt, StgAddr, StgInt, StgInt)); + +/* connectSocket.lc */ +StgInt connectSocket PROTO((StgInt, StgAddr, StgInt, StgInt)); + +/* createSocket.lc */ +StgInt createSocket PROTO((StgInt, StgInt, StgInt)); + +/* getSockName.lc */ +StgInt getSockName PROTO((StgInt, StgAddr, StgAddr)); + +/* getPeerName.lc */ +StgInt getPeerName PROTO((StgInt, StgAddr, StgAddr)); + +/* listenSocket.lc */ +StgInt listenSocket PROTO((StgInt, StgInt)); + +/* shutdownSocket.lc */ +StgInt shutdownSocket PROTO((StgInt, StgInt)); + +/* readDescriptor.lc */ +StgInt readDescriptor PROTO((StgInt, StgAddr, StgInt)); + +/* writeDescriptor.lc */ +StgInt writeDescriptor PROTO((StgInt, StgAddr, StgInt)); + + #endif /* !GHC_SOCKETS_H */ diff --git a/ghc/includes/libposix.h b/ghc/includes/libposix.h index 45350619b4..4ce0ceafc1 100644 --- a/ghc/includes/libposix.h +++ b/ghc/includes/libposix.h @@ -1,8 +1,4 @@ #ifndef LIBPOSIX_H -#ifdef HAVE_SYS_TYPES_H -#include <sys/types.h> -#endif /* HAVE_SYS_TYPES_H */ - #ifdef HAVE_SYS_WAIT_H #include <sys/wait.h> #endif /* HAVE_SYS_WAIT_H */ diff --git a/ghc/includes/mkNativeHdr.lc b/ghc/includes/mkNativeHdr.lc index 2e2ae88c43..e590043578 100644 --- a/ghc/includes/mkNativeHdr.lc +++ b/ghc/includes/mkNativeHdr.lc @@ -42,8 +42,8 @@ #define SM_CAFLIST OFFSET(StorageMgrInfo, StorageMgrInfo.CAFlist) #define SM_OLDMUTABLES OFFSET(StorageMgrInfo, StorageMgrInfo.OldMutables) #define SM_OLDLIM OFFSET(StorageMgrInfo, StorageMgrInfo.OldLim) -#define SM_MALLOCPTRLIST OFFSET(StorageMgrInfo, StorageMgrInfo.MallocPtrList) -#define SM_OLDMALLOCPTRLIST OFFSET(StorageMgrInfo, StorageMgrInfo.OldMallocPtrList) +#define SM_FOREIGNOBJLIST OFFSET(StorageMgrInfo, StorageMgrInfo.ForeignObjList) +#define SM_OLDFOREIGNOBJLIST OFFSET(StorageMgrInfo, StorageMgrInfo.OldForeignObjList) #define SM_STABLEPOINTERTABLE OFFSET(StorageMgrInfo, StorageMgrInfo.StablePointerTable) STGRegisterTable MainRegTable; @@ -98,9 +98,9 @@ main() printf("#define SM_OLDLIM %d\n", SM_OLDLIM); #endif #ifndef PAR - printf("#define SM_MALLOCPTRLIST %d\n", SM_MALLOCPTRLIST); + printf("#define SM_FOREIGNOBJLIST %d\n", SM_FOREIGNOBJLIST); #if defined(GCap) || defined(GCgn) - printf("#define SM_OLDMALLOCPTRLIST %d\n", SM_OLDMALLOCPTRLIST); + printf("#define SM_OLDFOREIGNOBJLIST %d\n", SM_OLDFOREIGNOBJLIST); #endif printf("#define SM_STABLEPOINTERTABLE %d\n", SM_STABLEPOINTERTABLE); #endif diff --git a/ghc/includes/stgdefs.h b/ghc/includes/stgdefs.h index 88b0f40007..d6d7f66029 100644 --- a/ghc/includes/stgdefs.h +++ b/ghc/includes/stgdefs.h @@ -87,6 +87,22 @@ extern int sscanf PROTO((const char *, const char *, ...)); /* end of hack */ #endif /* STDC_HEADERS */ +/* + * threadWaitWrite# uses FD_SETSIZE to distinguish + * between read file descriptors and write fd's. + * Hence we need to include <sys/types.h>, but + * is this the best place to do it? + * (the following has been moved from libposix.h) + */ + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif /* HAVE_SYS_TYPES_H */ + +#ifndef FD_SETSIZE +#define FD_SETSIZE 1024 +#endif + #if ! defined(EXIT_SUCCESS) || ! defined(EXIT_FAILURE) /* "stdlib.h" should have defined these; but at least on SunOS 4.1.3, this is not so. @@ -188,13 +204,18 @@ extern StgFunPtr returnMain(STG_NO_ARGS); extern StgFunPtr impossible_jump_after_switch(STG_NO_ARGS); /* hooks: user might write some of their own */ -extern void ErrorHdrHook PROTO((FILE *)); -extern void OutOfHeapHook PROTO((W_)); -extern void StackOverflowHook PROTO((I_)); -extern void MallocFailHook PROTO((I_, char *)); -extern void PatErrorHdrHook PROTO((FILE *)); -extern void PreTraceHook PROTO((FILE *)); -extern void PostTraceHook PROTO((FILE *)); +void ErrorHdrHook PROTO((FILE *)); +void OutOfHeapHook PROTO((W_)); +void StackOverflowHook PROTO((I_)); +#ifdef CONCURRENT +void NoRunnableThreadsHook (STG_NO_ARGS); +#endif +void MallocFailHook PROTO((I_, char *)); +void PatErrorHdrHook PROTO((FILE *)); +void PreTraceHook PROTO((FILE *)); +void PostTraceHook PROTO((FILE *)); +void defaultsHook (STG_NO_ARGS); +void initEachPEHook (STG_NO_ARGS); EXTFUN(startStgWorld); #ifdef CONCURRENT diff --git a/ghc/includes/stgio.h b/ghc/includes/stgio.h index 972b96eb93..26f09ee3b5 100644 --- a/ghc/includes/stgio.h +++ b/ghc/includes/stgio.h @@ -17,7 +17,7 @@ StgInt createDirectory PROTO((StgByteArray)); char * strDup PROTO((const char *)); int setenviron PROTO((char **)); int copyenv (STG_NO_ARGS); -int setenv PROTO((char *)); +int _setenv PROTO((char *)); int delenv PROTO((char *)); /* errno.lc */ @@ -122,4 +122,39 @@ StgAddr toClockSec PROTO((StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt /* writeFile.lc */ StgInt writeFile PROTO((StgAddr, StgAddr, StgInt)); +/* SOCKET THINGS ALL TOGETHER: */ + +#if 0 +LATER +/* acceptSocket.lc */ +StgInt acceptSocket(I_ sockfd, A_ peer, A_ addrlen); + +/* bindSocket.lc */ +StgInt bindSocket(I_ sockfd, A_ myaddr, I_ addrlen, I_ isUnixDomain); + +/* connectSocket.lc */ +StgInt connectSocket(I_ sockfd, A_ servaddr, I_ addrlen, I_ isUnixDomain); + +/* createSocket.lc */ +StgInt createSocket(I_ family, I_ type, I_ protocol); + +/* getPeerName.lc */ +StgInt getPeerName(int sockfd, struct sockaddr *peer, int *namelen); + +/* getSockName.lc */ +StgInt getSockName(int sockfd, struct sockaddr *peer, int *namelen); + +/* listenSocket.lc */ +StgInt listenSocket(int sockfd, int backlog); + +/* readDescriptor.lc */ +StgInt readDescriptor(int fd, char *buf, int nbytes); + +/* shutdownSocket.lc */ +StgInt shutdownSocket(int sockfd, int how); + +/* writeDescriptor.lc */ +StgInt writeDescriptor(int fd, char *buf, int nbytes); +#endif /* 0 */ + #endif /* ! STGIO_H */ diff --git a/ghc/includes/timezone.h b/ghc/includes/timezone.h index 75a287f109..bedafdf350 100644 --- a/ghc/includes/timezone.h +++ b/ghc/includes/timezone.h @@ -21,8 +21,8 @@ #else #if HAVE_TZNAME extern time_t timezone, altzone; -extern char *tmzone[2]; -#define ZONE(x) (((struct tm *)x)->tm_isdst ? tmzone[1] : tmzone[0]) +extern char *tzname[2]; +#define ZONE(x) (((struct tm *)x)->tm_isdst ? tzname[1] : tzname[0]) #define SETZONE(x,z) #define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone) #endif |