--- /dev/null
+ 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).
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
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
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
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
# 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
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
#! /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
#
# 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
# 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 ;;
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 ;;
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
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
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]*//'`
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:*:*)
*: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[];
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*:*)
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
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-*:*:*)
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)
#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)
#! /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.
#
# 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
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/'`
-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.
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-* \
| 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
;;
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
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
;;
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
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
;;
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
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
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
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
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
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
;;
basic_machine=sh-hitachi
os=-hms
;;
+ sparclite-wrs) # CYGNUS LOCAL
+ basic_machine=sparclite-wrs
+ os=-vxworks
+ ;;
sps7)
basic_machine=m68k-bull
os=-sysv2
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
;;
basic_machine=a29k-nyu
os=-sym1
;;
+ v810 | necv810) # CYGNUS LOCAL
+ basic_machine=v810-nec
+ os=-none
+ ;;
vaxv)
basic_machine=vax-dec
os=-sysv
basic_machine=a29k-wrs
os=-vxworks
;;
+ w65*) # CYGNUS LOCAL
+ basic_machine=w65-wdc
+ os=-none
+ ;;
xmp)
basic_machine=xmp-cray
os=-unicos
xps | xps100)
basic_machine=xps100-honeywell
;;
+ z8k-*-coff) # CYGNUS LOCAL
+ basic_machine=z8k-unknown
+ os=-sim
+ ;;
none)
basic_machine=none-none
os=-none
# 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
;;
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
# 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|'`
;;
-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|'`
# This must come after -sysvr4.
-sysv*)
;;
+ -ose*) # CYGNUS LOCAL
+ os=-ose
+ ;;
+ -es1800*) # CYGNUS LOCAL
+ os=-ose
+ ;;
-xenix)
os=-xenix
;;
# 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
;;
*-ibm)
os=-aix
;;
+ *-wec) # CYGNUS LOCAL
+ os=-proelf
+ ;;
+ *-winbond) # CYGNUS LOCAL
+ os=-proelf
+ ;;
+ *-oki) # CYGNUS LOCAL
+ os=-proelf
+ ;;
*-hp)
os=-hpux
;;
m88k-omron*)
os=-luna
;;
+ *-next )
+ os=-nextstep
+ ;;
*-sequent)
os=-ptx
;;
*-masscomp)
os=-rtu
;;
+ *-rom68k) # CYGNUS LOCAL
+ os=-coff
+ ;;
+ *-*bug) # CYGNUS LOCAL
+ os=-coff
+ ;;
+ *-apple) # CYGNUS LOCAL
+ os=-macos
+ ;;
*)
os=-none
;;
-sunos*)
vendor=sun
;;
+ -bosx*) # CYGNUS LOCAL
+ vendor=bull
+ ;;
-lynxos*)
vendor=lynx
;;
-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/"`
;;
#
# 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'...
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'
**********************************************************************
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.
# 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
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'
;;
fi
AC_SUBST(DoingGHC)
+AC_SUBST(DoingHsLibs)
AC_SUBST(DoingNoFib)
AC_SUBST(DoingHappy)
AC_SUBST(DoingHaggis)
# 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
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
# 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
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
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
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
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
fi
fi
+dnl ** Find lex command (lex or flex) and library (-ll or -lfl)
+#
+AC_PROG_LEX
+
#--------------------------------------------------------------
WithHc='haskell-compiler-unspecified'
WithHcType='HC_UNSPECIFIED'
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)
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)
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
#
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)
;;
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)
# first, the defaults...
WithGhcHc='haskell-compiler-unspecified'
WithGhcHcType='HC_UNSPECIFIED'
-GhcBuilderVersion='26'
+GhcBuilderVersion='28'
AC_ARG_WITH(hc-for-ghc,
[
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
IncludeRealNoFibTests='YES' # defaults
IncludeSpectralNoFibTests='YES'
IncludeImaginaryNoFibTests='YES'
-IncludePENDINGNoFibTests='NO'
-IncludeUNUSEDNoFibTests='NO'
+IncludeSpecialiseNoFibTests='NO'
IncludeGHC_ONLYNoFibTests='NO'
IncludePRIVATENoFibTests='NO'
IncludeParallelNoFibTests='NO'
--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'
;;
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])
;;
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
#
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'
#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".
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,,)
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; \
-The Glamorous Glasgow Haskell Compiler, version 0.27, patchlevel 0
+The Glamorous Glasgow Haskell Compiler, version 2.01, patchlevel 0
+(for Haskell 1.3)
-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
/* just documents here */
#define NoAllTargetForSubdirs
+#define NoDependTargetForSubdirs
#define NoRunTestsTargetForSubdirs
#define NoInstallTargetForSubdirs
#define NoTagTargetForSubdirs
%
-% $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}
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
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
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)
@
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
@
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:
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}
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:
... 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}
-- 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
\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
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
%
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}
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).
\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
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}
\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).
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).
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
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
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)
$(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.
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}}
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 $}
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}
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}
%************************************************************************
%* *
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
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
/* 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 */
$(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))
DYN_LOADABLE_LPRLS = $(DYN_LOADABLE_BITS:.prl=.lprl)
PerlTagsTarget( ghc.lprl $(DYN_LOADABLE_LPRLS) )
-
-LitDocRootTargetWithNamedOutput(driver,lit,driver-standalone)
+++ /dev/null
-\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}
+++ /dev/null
-%************************************************************************
-%* *
-\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}
+++ /dev/null
-%************************************************************************
-%* *
-\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}
+++ /dev/null
-%************************************************************************
-%* *
-\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}
+++ /dev/null
-%************************************************************************
-%* *
-\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}
+++ /dev/null
-# 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;
+++ /dev/null
-%************************************************************************
-%* *
-\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}
+++ /dev/null
-%************************************************************************
-%* *
-\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}
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}
\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
$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
$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";
$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)
$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";
$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 ) {
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";
%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});
$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!!!!
|| /^${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/
# 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)
# 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
# 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
}
$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;
$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 ) {
$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'
$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;
# 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';
}
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 {
\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) = @_;
# 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 ???
#= 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 $_;
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";
\end{code}
\begin{code}
-sub mini_mangle_asm {
+sub mini_mangle_asm_i386 {
local($in_asmf, $out_asmf) = @_;
&init_TARGET_STUFF();
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;
--- /dev/null
+%************************************************************************
+%* *
+\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}
--- /dev/null
+%************************************************************************
+%* *
+\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}
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");
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)
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;
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
# 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;
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;
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
# 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
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
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)
$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";
$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, ''); }
# 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
: "$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"
@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)";
# 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}
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,''
$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)
%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',
'_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;
# 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\');',
@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)")
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
$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 = ();
# 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}
%************************************************************************
@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',
/^-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; };
/^-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...
# "-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 =~ /(.*)\/[^\/]*$/) {
}
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 '-'
}
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;
}
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!
$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
/^-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 ));
# 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; };
# 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; };
$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; };
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$/
$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; };
# && 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
# ---------------
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");
$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; };
#*************** ... 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; };
/^-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.
#---------- 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>
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...)
\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',
# '-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
@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,
'-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',
'-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',
# '-ffoldr-build-worker-wrapper',
# '-fsimplify',
# '\(',
-# "$Oopt_FB_Support",
+# $Oopt_FB_Support,
# '-ffloat-lets-exposing-whnf',
# '-ffloat-primops-ok',
# '-fcase-of-case',
# '-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,
# '\)',
# ) : (),
'\(',
'-fignore-inline-pragma', # **** NB!
'-fdo-foldr-build', # NB
- "$Oopt_FB_Support",
+ $Oopt_FB_Support,
'-ffloat-lets-exposing-whnf',
'-ffloat-primops-ok',
'-fcase-of-case',
'-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,
'\)',
) : (),
'-fsimplify',
'\(',
- "$Oopt_FB_Support",
+ $Oopt_FB_Support,
'-ffloat-lets-exposing-whnf',
'-ffloat-primops-ok',
'-fcase-of-case',
# 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',
'-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',
# ( ($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',
$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',
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');
%************************************************************************
%* *
-\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; }
\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});
}
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}
%************************************************************************
# 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
#
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__'));
# 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__'));
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}
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}
%************************************************************************
\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...
$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;
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}
%************************************************************************
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');
$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");
exit(1);
EOSCRIPT2
close(EXEC) || die "Failed closing $executable\n";
- chmod 0755, "$executable";
+ chmod 0755, $executable;
}
}
\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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
\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);
}
}
\end{code}
+
\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"
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}
%************************************************************************
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}
#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
%************************************************************************
\begin{code}
-
#if sparc_TARGET_ARCH
#define MAGIC_CALL_SETUP \
"\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" \
__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 ( \
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) */
# 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)
# 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)
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)
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,
# 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))
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.
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) \
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}
# 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); \
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)
# 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 */
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}
\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);
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}
%* *
%************************************************************************
+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_));
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}
#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 */
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)
# define SET_TASK_ACTIVITY(act) /* nothing */
-# else
-# ifdef GRAN
+#endif
+
+#if defined(GRAN)
# define GA_HDR_SIZE 1
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}
%************************************************************************
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
%************************************************************************
\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)
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_ */
# 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}
+
+
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;
# define DESCRchar 'D'
# define TYPEchar 'Y'
# define TIMEchar 'T'
+
+ char *ccSelector;
+ char *modSelector;
+ char *grpSelector;
+ char *descrSelector;
+ char *typeSelector;
+ char *kindSelector;
};
#endif
#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 */
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
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 */
} *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}
%************************************************************************
%* *
-\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 */
#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}
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
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 \
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}
%************************************************************************
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[]; \
\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[]; \
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[]; \
%************************************************************************
%* *
-\subsection[MallocPtr_ITBL]{@MallocPtr_TBL@: @MallocPtr@ info-table}
+\subsection[ForeignObj_ITBL]{@ForeignObj_TBL@: @ForeignObj@ info-table}
%* *
%************************************************************************
\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 */
/* 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}
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;
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;
#endif
#ifndef PAR
-extern StgScanFun _ScanMove_MallocPtr;
+extern StgScanFun _ScanMove_ForeignObj;
#endif /* !PAR */
extern StgScanFun _ScanMove_ImmuTuple;
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;
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;
#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;
#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
@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
\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}
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 */
#define _INFO_MARKING
#else
-/* NO_INFO_SPECIFIED (ToDo: an #error ???) */
+/* NO_INFO_SPECIFIED (ToDo: an #error ?) */
#endif
#endif
#endif
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);
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);
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);
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);
(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
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
#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 */
#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)
%************************************************************************
\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}
#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
} \
SET_INFO_PTR(node, EmptySVar_info); \
r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = Nil_closure; \
+ SVAR_VALUE(node) = Prelude_Z91Z93_closure; \
}
#endif
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; \
} \
}
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; \
} \
}
#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); \
} \
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); \
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); \
#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); \
}
/* 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); \
}
\
newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
+ CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
stablePtr = newSP; \
} while (0)
\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;
r = 1; /* Should not be necessary */ \
}
+#endif /* GRAN */
\end{code}
The following seq# code should only be used in unoptimized code.
#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; \
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
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)
StgDouble & double \\
StgChar & unsigned char \\\hline
StgStablePtr & long \\
-StgMallocPtr & (long *) \\
+StgForeignObj & (long *) \\
\end{tabular}
%partain:\end{center}
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
\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
#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];
#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[];
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 */
#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;
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_));
#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
#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])
#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) \
#define Q_RUNNABLE 'A'
#define Q_BLOCKED 'R'
#define Q_FETCHING 'Y'
+#define Q_MIGRATING 'B'
\end{code}
%************************************************************************
#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}
/* 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. */
#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 */
#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 */
#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;
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
/* 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.
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
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 */
/* 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 */
#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
projects / ghc-hetmet.git / commitdiff